Fix bulk of function header parser

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: $ =>

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"
+example = "../../../src/test/contracts/address.ligo"

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