From a8b898d39696a91482b1f9d8fa3ebfb19b30a00a Mon Sep 17 00:00:00 2001
From: Kirill Andreev <hindmost.one@gmail.com>
Date: Wed, 6 May 2020 21:26:00 +0400
Subject: [PATCH] Improve grammar, add Parsers for many things

---
 tools/lsp/pascaligo/grammar.js       |  29 +--
 tools/lsp/squirrel/src/AST/Parser.hs | 326 ++++++++++++++++++++-------
 tools/lsp/squirrel/src/AST/Types.hs  |  71 ++++--
 tools/lsp/squirrel/src/Parser.hs     |  32 ++-
 4 files changed, 341 insertions(+), 117 deletions(-)

diff --git a/tools/lsp/pascaligo/grammar.js b/tools/lsp/pascaligo/grammar.js
index 617820755..6263a80a0 100644
--- a/tools/lsp/pascaligo/grammar.js
+++ b/tools/lsp/pascaligo/grammar.js
@@ -218,12 +218,12 @@ module.exports = grammar({
 
     _open_data_decl: $ =>
       choice(
-        $.open_const_decl,
-        $.open_var_decl,
+        $.const_decl,
+        $.var_decl,
         $.fun_decl,
       ),
 
-    open_const_decl: $ =>
+    const_decl: $ =>
       seq(
         'const',
         field("name", $.Name),
@@ -233,7 +233,7 @@ module.exports = grammar({
         field("value", $._expr),
       ),
 
-    open_var_decl: $ =>
+    var_decl: $ =>
       seq(
         'var',
         field("name", $.Name),
@@ -243,11 +243,6 @@ module.exports = grammar({
         field("value", $._expr),
       ),
 
-    const_decl: $ =>
-      seq(
-        $.open_const_decl,
-      ),
-
     _instruction: $ =>
       choice(
         $.conditional,
@@ -476,14 +471,14 @@ module.exports = grammar({
     op_expr: $ =>
       choice(
         field("the", $._core_expr),
-        prec.left (0, seq(field("arg1", $.op_expr),    'or',         field("arg2", $.op_expr))),
-        prec.left (1, seq(field("arg1", $.op_expr),    'and',        field("arg2", $.op_expr))),
-        prec.right(2, seq(field("arg1", $._core_expr), 'contains',   field("arg2", $.op_expr))),
-        prec.left (3, seq(field("arg1", $.op_expr),    $.comparison, field("arg2", $.op_expr))),
-        prec.right(4, seq(field("arg1", $.op_expr),    '^',          field("arg2", $.op_expr))),
-        prec.right(5, seq(field("arg1", $.op_expr),    '#',          field("arg2", $.op_expr))),
-        prec.left (6, seq(field("arg1", $.op_expr),    $.adder,      field("arg2", $.op_expr))),
-        prec.left (7, seq(field("arg1", $.op_expr),    $.multiplier, field("arg2", $.op_expr))),
+        prec.left (0, seq(field("arg1", $.op_expr),    field("op", 'or'),         field("arg2", $.op_expr))),
+        prec.left (1, seq(field("arg1", $.op_expr),    field("op", 'and'),        field("arg2", $.op_expr))),
+        prec.right(2, seq(field("arg1", $._core_expr), field("op", 'contains'),   field("arg2", $.op_expr))),
+        prec.left (3, seq(field("arg1", $.op_expr),    field("op", $.comparison), field("arg2", $.op_expr))),
+        prec.right(4, seq(field("arg1", $.op_expr),    field("op", '^'),          field("arg2", $.op_expr))),
+        prec.right(5, seq(field("arg1", $.op_expr),    field("op", '#'),          field("arg2", $.op_expr))),
+        prec.left (6, seq(field("arg1", $.op_expr),    field("op", $.adder),      field("arg2", $.op_expr))),
+        prec.left (7, seq(field("arg1", $.op_expr),    field("op", $.multiplier), field("arg2", $.op_expr))),
         prec.right(8, seq(field("negate", $.negate), field("arg", $._core_expr))),
       ),
 
diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs
index 6779c0d57..1fcf35e91 100644
--- a/tools/lsp/squirrel/src/AST/Parser.hs
+++ b/tools/lsp/squirrel/src/AST/Parser.hs
@@ -3,7 +3,7 @@ module AST.Parser (example, contract) where
 
 import Data.Text (Text)
 
-import AST.Types
+import AST.Types hiding (tuple)
 
 import Parser
 import Range
@@ -15,20 +15,58 @@ name = do
   (raw, info) <- range (token "Name")
   return Name {info, raw}
 
+capitalName :: Parser (Name Range)
+capitalName = do
+  (raw, info) <- range (token "Name_Capital")
+  return Name {info, raw}
+
 contract :: Parser (Contract Range)
 contract = subtree "contract" do
   (decls, info) <- range do
-    gets (length . pfGrove) >>= traceShowM
-    many "declaration" declaration <* (gets (length . pfGrove) >>= traceShowM)
+    many "declaration" do
+      inside "declaration:" do
+        declaration
 
   return (Contract info decls)
 
 declaration :: Parser (Declaration Range)
-declaration =
-  stubbed "declaration" do
-    field "declaration" do
-        (b, info) <- range binding
-        return (ValueDecl info b)
+declaration = do
+    (b, info) <- range binding
+    return (ValueDecl info b)
+  <|> do
+    (b, info) <- range vardecl
+    return (ValueDecl info b)
+  <|> do
+    (b, info) <- range constdecl
+    return (ValueDecl info b)
+  <|>
+    typedecl
+
+typedecl :: Parser (Declaration Range)
+typedecl = do
+  subtree "type_decl" do
+    r <- getRange
+    n <- inside "typeName:"  name
+    t <- inside "typeValue:" newtype_
+    return $ TypeDecl r n t
+
+vardecl :: Parser (Binding Range)
+vardecl = do
+  subtree "var_decl" do
+    r  <- getRange
+    n  <- inside "name:"  name
+    ty <- inside "type:"  type_
+    b  <- inside "value:" expr
+    return (Var r n ty b)
+
+constdecl :: Parser (Binding Range)
+constdecl = do
+  subtree "const_decl" do
+    r  <- getRange
+    n  <- inside "name" name
+    ty <- inside "type" type_
+    b  <- inside "value" expr
+    return (Const r n ty b)
 
 par x = do
   consume "("
@@ -39,89 +77,191 @@ par x = do
 binding :: Parser (Binding Range)
 binding = do
   info <- getRange
-  "fun_decl" `subtree` do
-    recur <- optional do
-      field "recursive" do
-        token "recursive"
-    consume "function"
-    name <- stubbed "name" do
-      field "name" do
-        name
+  inside ":fun_decl" do
+    recur <- optional $ inside "recursive" $ token "recursive"
+    name  <- inside "name:"  name
     params <-
-      field "parameters" do
-        subtree "parameters" do
-          par do
-            many "param" do
-              notFollowedBy do
-                consumeOrDie ")"
+      inside "parameters:parameters" do
+        many "param" do
+          notFollowedBy do
+            consumeOrDie ")"
 
-              stubbed "parameters" do
-                paramDecl
-    consume ":"
-    ty <-
-      stubbed "type" do
-        field "type" type_
-    consume "is"
-    exp <- stubbed "body" do
-      field "body" letExpr
+          stubbed "parameters" paramDecl
+    ty  <- inside "type:" type_
+    exp <- inside "body:" letExpr
     return (Function info (recur == Just "recursive") name params ty exp)
 
 expr :: Parser (Expr Range)
-expr = select
-  [ Ident <$> getRange <*> name
-  -- , ident
-  -- , constant
-  ]
+expr = stubbed "expr" do
+  select
+    [ Ident <$> getRange <*> do
+        r <- getRange
+        n <- name
+        return $ QualifiedName r n []
+    , opCall
+    , fun_call
+    , record_expr
+    , int_literal
+    , par_call
+    , method_call
+    -- , if_expr
+    -- , constant
+    ]
   where
   -- $.case_expr,
   -- $.cond_expr,
   -- $.disj_expr,
   -- $.fun_expr,
 
+method_call :: Parser (Expr Range)
+method_call = do
+  subtree "projection_call" do
+    r <- getRange
+    (f, r') <- field "f" $ range projection
+    xs <- inside "arguments" arguments
+    return $ Apply r (Ident r' f) xs
+
+projection :: Parser (QualifiedName Range)
+projection = do
+  subtree "data_projection" do
+    r  <- getRange
+    s  <- inside "struct" name
+    is <- many "selection" selection
+    return $ QualifiedName r s is
+
+selection :: Parser (Path Range)
+selection = do
+  inside "index:selection" $ do
+      r <- getRange
+      n <- name
+      return $ At r n
+    <|> do
+      r <- getRange
+      n <- token "Int"
+      return $ Ix r n
+
+par_call :: Parser (Expr Range)
+par_call = do
+  subtree "par_call" do
+    r  <- getRange
+    f  <- inside "f" expr
+    az <- inside "arguments" arguments
+    return $ Apply r f az
+
+int_literal :: Parser (Expr Range)
+int_literal = do
+  r <- getRange
+  i <- token "Int"
+  return $ Constant r (Int r i)
+
+record_expr :: Parser (Expr Range)
+record_expr = do
+  subtree "record_expr" do
+    r  <- getRange
+    az <- many "assignment" do
+      inside "assignment:field_assignment" do
+        r <- getRange
+        n <- inside "name" name
+        e <- inside "_rhs" expr
+        return $ Assignment r n e
+    return $ Record r az
+
+fun_call :: Parser (Expr Range)
+fun_call = do
+  subtree "fun_call" do
+    r <- getRange
+    (f, r') <- range $ inside "f" function_id
+    xs <- inside "arguments" do
+      arguments
+    return $ Apply r (Ident r' f) xs
+
+arguments =
+  subtree "arguments" do
+    many "argument" do
+      inside "argument" expr
+
+function_id :: Parser (QualifiedName Range)
+function_id = select
+  [ do
+      r <- getRange
+      n <- name
+      return $ QualifiedName r n []
+  , do
+      subtree "module_field" do
+        r     <- getRange
+        whole <- inside "module" capitalName
+        path  <- inside "method" name
+        return $ QualifiedName r whole [At r path]
+  ]
+
+opCall :: Parser (Expr Range)
+opCall = do
+  subtree "op_expr" $ do
+      inside "the" do
+        expr
+    <|> do
+      i <- getRange
+      l <- inside "arg1" expr
+      o <- inside "op"   anything
+      r <- inside "arg2" expr
+      return $ BinOp i l o r
+
 letExpr = do
   subtree "let_expr" do
     r <- getRange
     decls <- optional do
-      field "locals" do
-        subtree "block" do
-          many "decl" do
-            field "statement" do
-              declaration
-    body <- field "body" do
-      -- gets pfGrove >>= traceShowM
-      stubbed "expr" do
-        expr
+      inside "locals:block" do
+        many "decl" do
+          inside "statement" do
+            declaration <|> statement
+    body <- inside "body"expr
 
     return case decls of
       Just them -> Let r them body
       Nothing   -> body
 
+statement :: Parser (Declaration Range)
+statement = do
+  r <- getRange
+  e <- expr
+  return $ Action r e
+
 paramDecl :: Parser (VarDecl Range)
 paramDecl = do
   info <- getRange
-  "parameter" `field` do
-    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)
+  inside "parameter:param_decl" do
+    info' <- getRange
+    mutable <- do
+      inside ":access" do
+        select
+          [ consume "var"   >> return (Mutable   info')
+          , consume "const" >> return (Immutable info')
+          ]
+    name <- inside "name" name
+    ty <- inside "type" type_
+    return (Decl info mutable name ty)
 
-newtype_ = do
-  type_
+newtype_ = select
+  [ record_type
+  , type_
+  -- , sum_type
+  ]
+
+record_type = do
+  subtree "record_type" do
+    r  <- getRange
+    fs <- many "field" do
+      inside "field" do
+        field_decl
+    traceShowM fs
+    return $ TRecord r fs
+
+field_decl = do
+  subtree "field_decl" do
+    r <- getRange
+    n <- inside "fieldName" name
+    t <- inside "fieldType" type_
+    return $ TField r n t
 
 type_ :: Parser (Type Range)
 type_ =
@@ -129,35 +269,51 @@ type_ =
   where
     fun_type :: Parser (Type Range)
     fun_type = do
-      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
+      inside ":fun_type" do
+        info <- getRange
+        domain <- inside "domain" cartesian
+        codomain <- optional do
+          consume "->"
+          fun_type
+
+        return case codomain of
+          Just co -> TArrow info domain co
+          Nothing -> domain
 
     cartesian = do
-      stubbed "cartesian" do
-        subtree "cartesian" do
-          info <- getRange
-          Product info <$> some "corety" do
-            field "element" do
-              core_type
+      inside ":cartesian" do
+        info <- getRange
+        TProduct info <$> some "corety" do
+          inside "element" do
+            core_type
 
     core_type = do
       info <- getRange
       select
         [ TVar info <$> typename
+        , subtree "invokeBinary" do
+            r  <- getRange
+            f  <- inside "typeConstr" name
+            xs <- inside "arguments"  typeTuple
+            return $ TApply r f xs
         ]
 
     typename = name
 
+typeTuple :: Parser [Type Range]
+typeTuple = do
+  subtree "type_tuple" do
+    many "type tuple element" do
+      inside "element" type_
+
 tuple :: Text -> Parser a -> Parser [a]
 tuple msg = par . some msg
 
-example = "../../../src/test/contracts/address.ligo"
+-- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/address.ligo"
+example = "../../../src/test/contracts/amount.ligo"
+-- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/application.ligo"
diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs
index 8629b7a9a..5929a8d9e 100644
--- a/tools/lsp/squirrel/src/AST/Types.hs
+++ b/tools/lsp/squirrel/src/AST/Types.hs
@@ -26,6 +26,8 @@ instance Stubbed (Contract info) where stub = WrongContract
 
 data Declaration info
   = ValueDecl info (Binding info)
+  | TypeDecl  info (Name info) (Type info)
+  | Action    info (Expr info)
   | WrongDecl      Error
   deriving (Show) via PP (Declaration info)
 
@@ -59,30 +61,46 @@ instance Stubbed (Mutable info) where stub = WrongMutable
 
 data Type info
   = TArrow    info  (Type info) (Type info)
-  | Record    info [(Name info, Type info)]
+  | TRecord   info [TField info]
   | TVar      info  (Name info)
-  | Sum       info [(Name info, [Type info])]
-  | Product   info  [Type info]
+  | TSum      info [(Name info, [Type info])]
+  | TProduct  info  [Type info]
   | TApply    info  (Name info) [Type info]
   | WrongType      Error
   deriving (Show) via PP (Type info)
 
 instance Stubbed (Type info) where stub = WrongType
 
+data TField info
+  = TField info (Name info) (Type info)
+  | WrongTField Error
+  deriving (Show) via PP (TField info)
+
+instance Stubbed (TField info) where stub = WrongTField
+
 data Expr info
   = Let       info [Declaration info] (Expr info)
   | Apply     info (Expr info) [Expr info]
   | Constant  info (Constant info)
-  | Ident     info (Name info)
+  | Ident     info (QualifiedName info)
+  | BinOp     info (Expr info) Text (Expr info)
+  | Record    info [Assignment info]
   | WrongExpr      Error
   deriving (Show) via PP (Expr info)
 
 instance Stubbed (Expr info) where stub = WrongExpr
 
+data Assignment info
+  = Assignment info (Name info) (Expr info)
+  | WrongAssignment Error
+  deriving (Show) via PP (Assignment info)
+
+instance Stubbed (Assignment info) where stub = WrongAssignment
+
 data Constant info
-  = Int     info Int
+  = Int     info Text
   | String  info Text
-  | Float   info Double
+  | Float   info Text
   | Bytes   info Text
   | WrongConstant Error
   deriving (Show) via PP (Constant info)
@@ -102,13 +120,21 @@ data QualifiedName info
   = QualifiedName
     { qnInfo   :: info
     , qnSource :: Name info
-    , qnPath   :: [Name info]
+    , qnPath   :: [Path info]
     }
   | WrongQualifiedName Error
   deriving (Show) via PP (QualifiedName info)
 
 instance Stubbed (QualifiedName info) where stub = WrongQualifiedName
 
+data Path info
+  = At info (Name info)
+  | Ix info Text
+  | WrongPath Error
+  deriving (Show) via PP (Path info)
+
+instance Stubbed (Path info) where stub = WrongPath
+
 data Name info = Name
   { info    :: info
   , raw     :: Text
@@ -134,6 +160,8 @@ instance Pretty (Contract i) where
 instance Pretty (Declaration i) where
   pp = \case
     ValueDecl _ binding -> pp binding
+    TypeDecl  _ n ty    -> hang ("type" <+> pp n <+> "=") 2 (pp ty)
+    Action    _ e       -> pp e
     WrongDecl err       -> pp err
 
 instance Pretty (Binding i) where
@@ -160,7 +188,7 @@ instance Pretty (Binding i) where
         (pp value)
     Const _ name ty body ->
       hang
-        ("var" <+> pp name <+> ":" <+> pp ty <+> "=")
+        ("const" <+> pp name <+> ":" <+> pp ty <+> "=")
         2
         (pp body)
     WrongBinding err ->
@@ -186,10 +214,10 @@ instance Pretty (Mutable i) where
 instance Pretty (Type i) where
   pp = \case
     TArrow    _ dom codom -> parens (pp dom <+> "->" <+> pp codom)
-    Record    _ fields    -> wrap ["record [", "]"] $ vcat $ map ppField fields
+    TRecord   _ fields    -> "record [" <> (vcat $ map pp fields) <> "]"
     TVar      _ name      -> pp name
-    Sum       _ variants  -> vcat $ map ppCtor variants
-    Product   _ elements  -> fsep $ punctuate " *" $ map pp elements
+    TSum      _ variants  -> vcat $ map ppCtor variants
+    TProduct  _ elements  -> fsep $ punctuate " *" $ map pp elements
     TApply    _ f xs      -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
     WrongType   err       -> pp err
     where
@@ -204,14 +232,20 @@ instance Pretty (Expr i) where
     Apply     _ f xs       -> pp f <> tuple xs
     Constant  _ constant   -> pp constant
     Ident     _ qname      -> pp qname
+    BinOp     _ l o r      -> parens (pp l <+> pp o <+> pp r)
+    Record    _ az         -> "record [" <> (fsep $ punctuate ";" $ map pp az) <> "]"
     WrongExpr   err        -> pp err
 
+instance Pretty (Assignment i) where
+  pp = \case
+    Assignment      _ n e -> pp n <+> "=" <+> pp e
+    WrongAssignment   err -> pp err
 
 instance Pretty (Constant i) where
   pp = \case
-    Int           _ c   -> int c
+    Int           _ c   -> pp c
     String        _ c   -> doubleQuotes (pp c)
-    Float         _ c   -> double c
+    Float         _ c   -> pp c
     Bytes         _ c   -> pp c
     WrongConstant   err -> pp err
 
@@ -233,5 +267,16 @@ instance Pretty (Name i) where
     Name      _ raw -> pp raw
     WrongName err   -> pp err
 
+instance Pretty (Path i) where
+  pp = \case
+    At _ n -> pp n
+    Ix _ i -> pp i
+    WrongPath err -> pp err
+
+instance Pretty (TField i) where
+  pp = \case
+    TField _ n t -> hang (pp n <> ":") 2 (pp t)
+    WrongTField err -> pp err
+
 tuple :: Pretty p => [p] -> Doc
 tuple xs = parens (fsep $ punctuate "," $ map pp xs)
\ No newline at end of file
diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs
index 378fb9e23..7039778e5 100644
--- a/tools/lsp/squirrel/src/Parser.hs
+++ b/tools/lsp/squirrel/src/Parser.hs
@@ -10,6 +10,7 @@ import Control.Monad.Identity
 import Data.Foldable
 import Data.Text.Encoding
 import Data.Text (Text, pack, unpack)
+import qualified Data.Text as Text
 
 import qualified Data.ByteString as ByteString
 import Data.ByteString (ByteString)
@@ -266,7 +267,7 @@ delete _ [] = []
 delete k ((k', v) : rest) =
   if k == k'
   then rest
-  else (k', v) : delete k rest
+  else delete k rest
 
 notFollowedBy :: Parser a -> Parser ()
 notFollowedBy parser = do
@@ -283,4 +284,31 @@ class Stubbed a where
   stub :: Error -> a
 
 instance Stubbed Text where
-  stub = pack . show
\ No newline at end of file
+  stub = pack . show
+
+instance Stubbed [a] where
+  stub _ = []
+
+inside :: Stubbed a => Text -> Parser a -> Parser a
+inside sig parser = do
+  let (f, st') = Text.breakOn ":" sig
+  let st       = Text.drop 1 st'
+  if Text.null f
+  then do
+    traceShowM ("subtree", st)
+    subtree st do
+      traceShowM ("stubbed", st)
+      stubbed f do
+        parser
+  else do
+    traceShowM ("field", f)
+    field f do
+      traceShowM ("stubbed", f)
+      stubbed f do
+        if Text.null st
+        then do
+          parser
+        else do
+          traceShowM ("subtree", st)
+          subtree st do
+            parser