Add [Big]Map literal/removal/projection parser

2020-05-07 00:31:05 +04:00 · 2020-05-07 00:31:05 +04:00 · b4e6231340
commit b4e6231340
parent 2f269e32ea
4 changed files with 139 additions and 14 deletions
--- a/tools/lsp/pascaligo/grammar.js
+++ b/tools/lsp/pascaligo/grammar.js
@ -560,8 +560,8 @@ module.exports = grammar({
        $.big_map_injection,
      ),

-    map_injection: $ => injection('map', $.binding),
-    big_map_injection: $ => injection('big_map', $.binding),
+    map_injection: $ => injection('map', field("binding", $.binding)),
+    big_map_injection: $ => injection('big_map', field("binding", $.binding)),

    map_lookup: $ =>
      seq(
--- a/tools/lsp/squirrel/src/AST/Parser.hs
+++ b/tools/lsp/squirrel/src/AST/Parser.hs
@ -97,6 +97,11 @@ expr = stubbed "expr" do
    , has_type
    , string_literal
    , attributes
+    , tuple_expr
+    , moduleQualified
+    , big_map_expr
+    , map_expr
+    , map_remove
    -- , constant
    ]
  where
@ -105,6 +110,53 @@ expr = stubbed "expr" do
  -- $.disj_expr,
  -- $.fun_expr,

+map_remove :: Parser (Expr ASTInfo)
+map_remove = do
+  subtree "map_remove" do
+    ctor MapRemove
+      <*> inside "key" expr
+      <*> inside "container" do
+        inside ":path" do
+          qname
+
+big_map_expr :: Parser (Expr ASTInfo)
+big_map_expr = do
+  subtree "big_map_injection" do
+    ctor BigMap <*> do
+      many "binding" do
+        inside "binding" do
+          map_binding
+
+map_expr :: Parser (Expr ASTInfo)
+map_expr = do
+  subtree "map_injection" do
+    ctor Map <*> do
+      many "binding" do
+        inside "binding" do
+          map_binding
+
+map_binding :: Parser (MapBinding ASTInfo)
+map_binding = do
+  subtree "binding" do
+    ctor MapBinding
+      <*> inside "key"   expr
+      <*> inside "value" expr
+
+moduleQualified :: Parser (Expr ASTInfo)
+moduleQualified = do
+  subtree "module_field" do
+    ctor Ident <*> do
+      ctor QualifiedName
+        <*> inside "module" capitalName
+        <*> do pure <$> do ctor At <*> inside "method" name
+
+tuple_expr :: Parser (Expr ASTInfo)
+tuple_expr = do
+  subtree "tuple_expr" do
+    ctor Tuple <*> do
+      many "tuple element" do
+        inside "element" expr
+
 attributes :: Parser (Expr ASTInfo)
 attributes = do
  subtree "attr_decl" do
@ -143,11 +195,29 @@ assign :: Parser (Expr ASTInfo)
 assign = do
  subtree "assignment" do
    ctor Assign
-      <*> inside "LHS" do
-              inside ":path" qname
-          <|> projection
+      <*> inside "LHS" lhs
      <*> inside "RHS" expr

+lhs :: Parser (LHS ASTInfo)
+lhs =
+  do ctor LHS
+       <*> inside "container:path" do
+             qname <|> projection
+       <*> pure Nothing
+  <|>
+  do ctor LHS
+       <*> subtree "path" do
+             qname <|> projection
+       <*> pure Nothing
+  <|>
+  do subtree "map_lookup" do
+       ctor LHS
+         <*> inside "container:path" do
+               qname <|> projection
+         <*> inside "index" do
+               Just <$> expr
+
+
 tez_literal :: Parser (Expr ASTInfo)
 tez_literal = do
  ctor Constant <*> do
@ -170,6 +240,7 @@ method_call = do

 projection :: Parser (QualifiedName ASTInfo)
 projection = do
+  gets pfGrove >>= traceShowM
  subtree "data_projection" do
    ctor QualifiedName
      <*> inside "struct" name
@ -180,6 +251,9 @@ selection = do
    inside "index:selection"
      $   do ctor At <*> name
      <|> do ctor Ix <*> token "Int"
+  <|>
+    inside "index" do
+      do ctor Ix <*> token "Int"

 par_call :: Parser (Expr ASTInfo)
 par_call = do
@ -315,7 +389,7 @@ type_ =
        [ ctor TVar <*> name
        , subtree "invokeBinary" do
            ctor TApply
-              <*> inside "typeConstr" name
+              <*> inside "typeConstr" name'
              <*> inside "arguments"  typeTuple
        , subtree "invokeUnary" do
            ctor TApply
@ -339,5 +413,20 @@ typeTuple = do
 -- example = "../../../src/test/contracts/annotation.ligo"
 -- example = "../../../src/test/contracts/arithmetic.ligo"
 -- example = "../../../src/test/contracts/assign.ligo"
-example = "../../../src/test/contracts/attributes.ligo"
+-- example = "../../../src/test/contracts/attributes.ligo"
+-- example = "../../../src/test/contracts/bad_timestamp.ligo"
+-- example = "../../../src/test/contracts/bad_type_operator.ligo"
+-- example = "../../../src/test/contracts/balance_constant.ligo"
+example = "../../../src/test/contracts/big_map.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"
+-- 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"
+-- example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/application.ligo"
--- a/tools/lsp/squirrel/src/AST/Types.hs
+++ b/tools/lsp/squirrel/src/AST/Types.hs
@ -87,15 +87,34 @@ data Expr info
  | UnOp      info Text (Expr info)
  | Record    info [Assignment info]
  | If        info (Expr info) (Expr info) (Expr info)
-  | Assign    info (QualifiedName info) (Expr info)
+  | Assign    info (LHS info) (Expr info)
  | List      info [Expr info]
+  | Tuple     info [Expr info]
  | Annot     info (Expr info) (Type info)
  | Attrs     info [Text]
+  | BigMap    info [MapBinding info]
+  | Map       info [MapBinding info]
+  | MapRemove info (Expr info) (QualifiedName info)
+  | SetRemove info (Expr info) (QualifiedName info)
  | WrongExpr      Error
  deriving (Show) via PP (Expr info)

 instance Stubbed (Expr info) where stub = WrongExpr

+data LHS info
+  = LHS info (QualifiedName info) (Maybe (Expr info))
+  | WrongLHS Error
+  deriving (Show) via PP (LHS info)
+
+instance Stubbed (LHS info) where stub = WrongLHS
+
+data MapBinding info
+  = MapBinding info (Expr info) (Expr info)
+  | WrongMapBinding Error
+  deriving (Show) via PP (MapBinding info)
+
+instance Stubbed (MapBinding info) where stub = WrongMapBinding
+
 data Assignment info
  = Assignment info (Name info) (Expr info)
  | WrongAssignment Error
@ -159,7 +178,7 @@ instance Pretty (Contract i) where
  pp = \case
    Contract _ decls ->
      hang "(* contract *)" 2 do
-        vcat $ map (($$ empty) . pp) decls
+        vcat $ punctuate "\n" $ map (($$ empty) . pp) decls

    WrongContract err ->
      pp err
@ -234,8 +253,7 @@ instance Pretty (Type i) where

 instance Pretty (Expr i) where
  pp = \case
-    Let       _ decls body -> hang "block {" 2 (vcat $ map pp decls)
-                           $$ hang "} with"  2 (pp body)
+    Let       _ decls body -> "block {" $$ (nest 2 $ vcat $ punctuate "\n" $ map pp decls) $$ "}" $$ "with" $$ nest 2 (pp body)
    Apply     _ f xs       -> pp f <> tuple xs
    Constant  _ constant   -> pp constant
    Ident     _ qname      -> pp qname
@ -245,10 +263,20 @@ instance Pretty (Expr i) where
    If        _ b t e      -> fsep ["if" <+> pp b, nest 2 $ "then" <+> pp t, nest 2 $ "else" <+> pp e]
    Assign    _ l r        -> hang (pp l <+> ":=") 2 (pp r)
    List      _ l          -> "[" <> fsep (punctuate ";" $ map pp l) <> "]"
+    Tuple     _ l          -> "(" <> fsep (punctuate "," $ map pp l) <> ")"
    Annot     _ n t        -> ("(" <> pp n) <+> ":" <+> (pp t <> ")")
    Attrs     _ ts         -> "attributes [" <> fsep (punctuate ";" $ map pp ts) <> "]"
+    BigMap    _ bs         -> "big_map [" <> fsep (punctuate ";" $ map pp bs) <> "]"
+    Map       _ bs         ->     "map [" <> fsep (punctuate ";" $ map pp bs) <> "]"
+    MapRemove _ k m        -> hang ("remove" <+> pp k) 0 ("from" <+> "map" <+> pp m)
+    SetRemove _ k s        -> hang ("remove" <+> pp k) 0 ("from" <+> "set" <+> pp s)
    WrongExpr   err        -> pp err

+instance Pretty (MapBinding i) where
+  pp = \case
+    MapBinding _ k v -> hang (pp k <+> "->") 2 (pp v)
+    WrongMapBinding err -> pp err
+
 instance Pretty (Assignment i) where
  pp = \case
    Assignment      _ n e -> pp n <+> "=" <+> pp e
@ -292,5 +320,10 @@ instance Pretty (TField i) where
    TField _ n t -> hang (pp n <> ":") 2 (pp t)
    WrongTField err -> pp err

+instance Pretty (LHS i) where
+  pp = \case
+    LHS _ qn mi -> pp qn <> foldMap (brackets . pp) mi
+    WrongLHS err -> pp err
+
 tuple :: Pretty p => [p] -> Doc
 tuple xs = parens (fsep $ punctuate "," $ map pp xs)
--- a/tools/lsp/squirrel/src/Parser.hs
+++ b/tools/lsp/squirrel/src/Parser.hs
@ -289,6 +289,9 @@ instance Stubbed Text where
 instance Stubbed [a] where
  stub _ = []

+instance Stubbed a => Stubbed (Maybe a) where
+  stub = Just . stub
+
 inside :: Stubbed a => Text -> Parser a -> Parser a
 inside sig parser = do
  let (f, st') = Text.breakOn ":" sig