From 017db45f8d2a119f0bde77bf0134b9cd0bc42bec Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Thu, 30 Apr 2020 17:46:39 +0400 Subject: [PATCH] Fix bulk of function header parser --- tools/lsp/pascaligo/grammar.js | 37 ++++++------- tools/lsp/squirrel/src/AST.hs | 94 +++++++++++++++++++++----------- tools/lsp/squirrel/src/Parser.hs | 53 +++++++++++++----- 3 files changed, 116 insertions(+), 68 deletions(-) diff --git a/tools/lsp/pascaligo/grammar.js b/tools/lsp/pascaligo/grammar.js index 87af734eb..2ceb2dc68 100644 --- a/tools/lsp/pascaligo/grammar.js +++ b/tools/lsp/pascaligo/grammar.js @@ -179,26 +179,23 @@ module.exports = grammar({ field("body", $._expr), ), - _open_fun_decl: $ => - seq( - field("recursive", optional($.recursive)), - 'function', - field("name", $.Name), - field("parameters", $.parameters), - ':', - field("type", $._type_expr), - 'is', - optional(seq( - field("locals", $.block), - 'with', - )), - field("body", $._expr), - ), - fun_decl: $ => - seq( - field("_open_fun_decl", $._open_fun_decl), - optional(';'), + prec.right(0, + seq( + field("recursive", optional($.recursive)), + 'function', + field("name", $.Name), + field("parameters", $.parameters), + ':', + field("type", $._type_expr), + 'is', + optional(seq( + field("locals", $.block), + 'with', + )), + field("body", $._expr), + optional(';'), + ), ), parameters: $ => par(sepBy(';', field("parameter", $.param_decl))), @@ -226,7 +223,7 @@ module.exports = grammar({ choice( $.open_const_decl, $.open_var_decl, - $._open_fun_decl, + $.fun_decl, ), open_const_decl: $ => diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index 169db028f..38b1e6424 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/tools/lsp/squirrel/src/AST.hs @@ -123,14 +123,16 @@ name = do contract :: Parser (Contract Range) contract = subtree "contract" do - (decls, info) <- range $ many "declaration" declaration + (decls, info) <- range do + many "declaration" declaration return (Contract info decls) declaration :: Parser (Declaration Range) declaration = - field "declaration" do - (b, info) <- range binding - return (ValueDecl info b) + stubbed "declaration" do + field "declaration" do + (b, info) <- range binding + return (ValueDecl info b) par x = do consume "(" @@ -146,32 +148,51 @@ binding = do field "recursive" do token "recursive" consume "function" - name <- field "name" do - name - params <- field "parameters" $ par (many "param" paramDecl) + name <- stubbed "name" do + field "name" do + name + params <- + field "parameters" do + subtree "parameters" do + par do + many "param" do + notFollowedBy do + consumeOrDie ")" + + stubbed "parameters" do + paramDecl consume ":" - ty <- field "type" type_ + ty <- + stubbed "type" do + field "type" type_ consume "is" - get >>= traceShowM - expr <- field "locals" anything + expr <- stubbed "body" do + field "locals" anything return (Function info (recur == Just "recursive") name params ty expr) paramDecl :: Parser (VarDecl Range) paramDecl = do info <- getRange "parameter" `field` do - info' <- getRange - mutable <- do - "access" `subtree` select - [ do consume "var" - return $ Mutable info' - , do consume "const" - return $ Immutable info' - ] - name <- field "name" name - consume ":" - ty <- field "type" type_ - return (Decl info mutable name ty) + subtree "param_decl" do + info' <- getRange + mutable <- do + traceM "paramDecl" + stubbed "access" do + "access" `subtree` do + traceM "paramDecl" + select + [ consume "var" >> return (Mutable info') + , consume "const" >> return (Immutable info') + ] + name <- + stubbed "name" do + field "name" name + consume ":" + ty <- + stubbed "type" do + field "type" type_ + return (Decl info mutable name ty) newtype_ = do type_ @@ -182,18 +203,25 @@ type_ = where fun_type :: Parser (Type Range) fun_type = do - info <- getRange - domain <- field "domain" cartesian - codomain <- optional do - consume "->" - fun_type - return case codomain of - Just co -> TArrow info domain co - Nothing -> domain + stubbed "type" do + subtree "fun_type" do + info <- getRange + domain <- stubbed "domain" do + field "domain" cartesian + codomain <- optional do + consume "->" + fun_type + return case codomain of + Just co -> TArrow info domain co + Nothing -> domain cartesian = do - info <- getRange - Product info <$> some "corety" core_type + stubbed "cartesian" do + subtree "cartesian" do + info <- getRange + Product info <$> some "corety" do + field "element" do + core_type core_type = do info <- getRange @@ -206,4 +234,4 @@ type_ = tuple :: Text -> Parser a -> Parser [a] tuple msg = par . some msg -example = "../../ligo/src/test/contracts/address.ligo" \ No newline at end of file +example = "../../../src/test/contracts/address.ligo" \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index b01cafbcc..e64cb487a 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -8,7 +8,6 @@ import Control.Monad.Except import Control.Monad.Identity import Data.Text.Encoding --- import Data.Traversable (for) import Data.Text (Text, pack, unpack) import qualified Data.ByteString as ByteString @@ -16,7 +15,7 @@ import Data.ByteString (ByteString) import ParseTree --- import Debug.Trace +import Debug.Trace data Error = Expected Text Range @@ -54,7 +53,7 @@ takeNext msg = do } return t -field :: Stubbed a => Text -> Parser a -> Parser a +field :: Text -> Parser a -> Parser a field name parser = do grove <- gets pfGrove case grove of @@ -77,7 +76,7 @@ field name parser = do , pfRange = ptRange } - stubbed name parser <* put st + parser <* put st { pfGrove = grove' , pfRange = if firstOne then diffRange rng ptRange else rng } @@ -116,13 +115,25 @@ many :: Text -> Parser a -> Parser [a] many msg p = many' where many' = some' <|> pure [] - some' = (:) <$> (productive msg p) <*> many' + some' = do + (x, consumed) <- productive p + if consumed then do + xs <- many' + return (x : xs) + else do + return [x] some :: Text -> Parser a -> Parser [a] some msg p = some' where many' = some' <|> pure [] - some' = (:) <$> (productive msg p) <*> many' + some' = do + (x, consumed) <- productive p + if consumed then do + xs <- many' + return (x : xs) + else do + return [x] getTreeID :: Parser (Maybe Int) getTreeID = Parser do @@ -130,14 +141,12 @@ getTreeID = Parser do [] -> Nothing (_, tree) : _ -> Just (ptID tree) -productive :: Text -> Parser a -> Parser a -productive msg p = do +productive :: Parser a -> Parser (a, Bool) +productive p = do was <- getTreeID res <- p now <- getTreeID - unless (was /= now) do - error ("unproductive: " ++ unpack msg) - return res + return (res, was /= now) data ParserEnv = ParserEnv { peRange :: Range @@ -182,6 +191,12 @@ consume node = do when (ptName /= node) do tell [Expected node ptRange] +consumeOrDie :: Text -> Parser () +consumeOrDie node = do + ParseTree {ptName, ptRange} <- takeNext node + when (ptName /= node) do + throwError $ Expected node ptRange + cutOut :: ByteString -> ParseTree -> Text cutOut bs (ParseTree _ _ s f _ _) = decodeUtf8 $ ByteString.take (f - s) (ByteString.drop s bs) @@ -207,11 +222,19 @@ delete k ((k', v) : rest) = then rest else (k', v) : delete k rest +notFollowedBy :: Parser a -> Parser () +notFollowedBy parser = do + good <- do + parser + return False + <|> do + return True + + unless good do + die "notFollowedBy" + class Stubbed a where stub :: Error -> a -instance Stubbed [a] where - stub _ = [] - instance Stubbed Text where - stub e = pack ("<" <> show e <> ">") + stub = pack . show \ No newline at end of file