Make parser recognise all src/tests/contracts

tools/lsp/pascaligo/grammar.js

@@ -100,12 +100,16 @@ module.exports = grammar({
       ),
 
     cartesian: $ =>
-      sepBy1('*', field("element", $._core_type)),
+      sepBy1('*',
+        choice(
+          field("element", $._core_type),
+          par(field("element", $.type_expr)),
+        ),
+      ),
 
     _core_type: $ =>
       choice(
         $.Name,
-        par($.type_expr),
         $.invokeBinary,
         $.invokeUnary,
       ),
@@ -551,7 +555,7 @@ module.exports = grammar({
         field("type", $._type_expr)
       )),
 
-    set_expr: $ => injection('set', $._expr),
+    set_expr: $ => injection('set', field("element", $._expr)),
 
     _map_expr: $ =>
       choice(
@@ -645,7 +649,7 @@ module.exports = grammar({
 
     field_path_assignment: $ =>
       seq(
-        sepBy1('.', field("index", $.Name)),
+        field("lhs", $.path),
         '=',
         field("_rhs", $._expr),
       ),
@@ -663,7 +667,11 @@ module.exports = grammar({
 
     _list_injection: $ => injection('list', field("element", $._expr)),
 
-    pattern: $ => sepBy1('#', field("arg", $._core_pattern)),
+    pattern: $ =>
+      choice(
+        $._cons_pattern,
+        field("the", $._core_pattern),
+      ),
 
     _core_pattern: $ =>
       choice(
@@ -679,12 +687,11 @@ module.exports = grammar({
 
     list_pattern: $ =>
       choice(
-        injection("list", field("element", $._core_pattern)),
+        injection("list", field("element", $.pattern)),
         'nil',
-        par($.cons_pattern),
       ),
 
-    cons_pattern: $ =>
+    _cons_pattern: $ =>
       seq(
         field("head", $._core_pattern),
         '#',
@@ -692,7 +699,7 @@ module.exports = grammar({
       ),
 
     tuple_pattern: $ =>
-      par(sepBy1(',', field("element", $._core_pattern))),
+      par(sepBy1(',', field("element", $.pattern))),
 
     _constr_pattern: $ => choice(
       $.Unit,
@@ -706,7 +713,7 @@ module.exports = grammar({
     Some_pattern: $ =>
       seq(
         field("constr", 'Some'),
-        par(field("arg", $._core_pattern)),
+        par(field("arg", $.pattern)),
       ),
 
     user_constr_pattern: $ =>
@@ -733,7 +740,7 @@ module.exports = grammar({
         '*)'
       ),
 
-    include: $ => seq('#include', $.String),
+    include: $ => seq('#include', field("filename", $.String)),
 
     String:       $ => /\"(\\.|[^"])*\"/,
     Int:          $ => /-?([1-9][0-9_]*|0)/,

tools/lsp/squirrel/app/Main.hs

@@ -1,6 +1,8 @@
 
 import Data.Foldable (for_)
 
+import Control.Monad (unless)
+
 import ParseTree
 import Parser
 import AST
@@ -13,7 +15,9 @@ main = do
   [fin] <- getArgs
   toParseTree fin >>= print
   (res, errs) <- runParser contract fin
+  putStrLn "----------------------"
   print (pp res)
+  unless (null errs) do
     putStrLn ""
     putStrLn "Errors:"
     for_ errs (print . nest 2 . pp)

tools/lsp/squirrel/src/AST/Parser.hs

@@ -29,8 +29,14 @@ declaration
   =   do ctor ValueDecl <*> binding
   <|> do ctor ValueDecl <*> vardecl
   <|> do ctor ValueDecl <*> constdecl
-  <|> typedecl
+  <|> do typedecl
   <|> do ctor Action <*> attributes
+  <|> do include
+
+include = do
+  subtree "include" do
+    ctor Include
+      <*> inside "filename" do token "String"
 
 typedecl :: Parser (Declaration ASTInfo)
 typedecl = do
@@ -42,10 +48,11 @@ typedecl = do
 vardecl :: Parser (Binding ASTInfo)
 vardecl = do
   subtree "var_decl" do
+    dump
     ctor Var
-      <*> inside "name:"  name
+      <*> inside "name"  name
-      <*> inside "type:"  type_
+      <*> inside "type"  type_
-      <*> inside "value:" expr
+      <*> inside "value" expr
 
 constdecl :: Parser (Binding ASTInfo)
 constdecl = do
@@ -63,17 +70,14 @@ binding = do
       <*> inside "name:"  name
       <*> inside "parameters:parameters" do
             many "param" do
-              notFollowedBy do
+              inside "parameter" paramDecl
-                consumeOrDie ")"
-
-              stubbed "parameters" paramDecl
       <*> inside "type:" type_
       <*> inside "body:" letExpr
 
 recursive = do
   mr <- optional do
     inside "recursive" do
-      token "recursie"
+      token "recursive"
 
   return $ maybe False (== "recursive") mr
 
@@ -102,13 +106,291 @@ expr = stubbed "expr" do
     , big_map_expr
     , map_expr
     , map_remove
-    -- , constant
+    , indexing
+    , constr_call
+    , nat_literal
+    , nullary_ctor
+    , bytes_literal
+    , case_expr
+    , skip
+    , case_action
+    , clause_block
+    , loop
+    , seq_expr
+    , lambda_expr
+    , set_expr
+    , map_patch
+    , record_update
+    , set_patch
+    , set_remove
     ]
+
+set_remove :: Parser (Expr ASTInfo)
+set_remove = do
+  subtree "set_remove" do
+    ctor SetRemove
+      <*> inside "key" expr
+      <*> inside "container" do
+        inside ":path" do
+          qname <|> projection
+
+set_patch = do
+  subtree "set_patch" do
+    ctor SetPatch
+      <*> inside "container:path" (qname <|> projection)
+      <*> many "key" do
+            inside "key" expr
+
+record_update = do
+  subtree "update_record" do
+    ctor RecordUpd
+      <*> inside "record:path" do qname <|> projection
+      <*> many "field" do
+            inside "assignment" field_path_assignment
+
+field_path_assignment = do
+  subtree "field_path_assignment" do
+    ctor FieldAssignment
+      <*> inside "lhs:path" do qname <|> projection
+      <*> inside "_rhs" expr
+
+map_patch = do
+  subtree "map_patch" do
+    ctor MapPatch
+      <*> inside "container:path" (qname <|> projection)
+      <*> many "binding" do
+            inside "binding" map_binding
+
+set_expr :: Parser (Expr ASTInfo)
+set_expr = do
+  subtree "set_expr" do
+    ctor List <*> do
+      many "list elem" do
+        inside "element" expr
+
+lambda_expr = do
+  subtree "fun_expr" do
+    ctor Lambda
+      <*> inside "parameters:parameters" do
+            many "param" do
+              inside "parameter" paramDecl
+      <*> inside "type" newtype_
+      <*> inside "body" expr
+
+seq_expr = do
+  subtree "block" do
+    dump
+    ctor Seq <*> do
+      many "statement" do
+        inside "statement" do
+          declaration <|> statement
+
+loop = do
+  subtree "loop" do
+    for_loop <|> while_loop <|> for_container
+
+for_container = do
+  subtree "for_loop" do
+    ctor ForBox
+      <*> inside "key" name
+      <*> optional do inside "value" name
+      <*> inside "kind" anything
+      <*> inside "collection" expr
+      <*> inside "body" (expr <|> seq_expr)
+
+while_loop = do
+  subtree "while_loop" do
+    ctor WhileLoop
+      <*> inside "breaker" expr
+      <*> inside "body"    expr
+
+for_loop = do
+  subtree "for_loop" do
+    ctor ForLoop
+      <*> inside "name"  name
+      <*> inside "begin" expr
+      <*> inside "end"   expr
+      <*> inside "body"  expr
+
+clause_block = do
+    subtree "clause_block" do
+      inside "block:block" do
+        ctor Seq <*> many "statement" do
+          inside "statement" (declaration <|> statement)
+  <|> do
+    subtree "clause_block" do
+      ctor Seq <*> many "statement" do
+        inside "statement" (declaration <|> statement)
+
+skip :: Parser (Expr ASTInfo)
+skip = do
+  ctor Skip <* token "skip"
+
+case_action :: Parser (Expr ASTInfo)
+case_action = do
+  subtree "case_instr" do
+    dump
+    ctor Case
+      <*> inside "subject" expr
+      <*> many "case" do
+            inside "case" alt_action
+
+alt_action :: Parser (Alt ASTInfo)
+alt_action = do
+  subtree "case_clause_instr" do
+    ctor Alt
+      <*> inside "pattern"        pattern
+      <*> inside "body:if_clause" expr
+
+case_expr :: Parser (Expr ASTInfo)
+case_expr = do
+  subtree "case_expr" do
+    ctor Case
+      <*> inside "subject" expr
+      <*> many "case" do
+            inside "case" alt
+
+alt :: Parser (Alt ASTInfo)
+alt = do
+  subtree "case_clause_expr" do
+    ctor Alt
+      <*> inside "pattern" pattern
+      <*> inside "body"    expr
+
+pattern :: Parser (Pattern ASTInfo)
+pattern = do
+  subtree "pattern" $ do
+      inside "the" core_pattern
+    <|>
+      do ctor IsCons
+           <*> inside "head" core_pattern
+           <*> inside "tail" pattern
+
+core_pattern :: Parser (Pattern ASTInfo)
+core_pattern
+  =  -- int_pattern
+  -- <|> nat_pattern
+  -- <|> var_pattern
+  -- <|> list_pattern
+  -- <|> tuple_pattern
+  -- <|>
+      constr_pattern
+  <|> string_pattern
+  <|> int_pattern
+  <|> nat_pattern
+  <|> tuple_pattern
+  <|> list_pattern
+  <|> some_pattern
+  <|> var_pattern
+
+var_pattern :: Parser (Pattern ASTInfo)
+var_pattern =
+  ctor IsVar <*> name
+
+some_pattern :: Parser (Pattern ASTInfo)
+some_pattern = do
+  subtree "Some_pattern" do
+    ctor IsConstr
+      <*> do inside "constr" do ctor Name <*> token "Some"
+      <*> do Just <$> inside "arg" pattern
+
+string_pattern :: Parser (Pattern ASTInfo)
+string_pattern =
+  ctor IsConstant <*> do
+    ctor String <*> token "String"
+
+nat_pattern :: Parser (Pattern ASTInfo)
+nat_pattern =
+  ctor IsConstant <*> do
+    ctor Nat <*> token "Nat"
+
+int_pattern :: Parser (Pattern ASTInfo)
+int_pattern =
+  ctor IsConstant <*> do
+    ctor Int <*> token "Int"
+
+constr_pattern :: Parser (Pattern ASTInfo)
+constr_pattern =
+    do
+      subtree "user_constr_pattern" do
+        ctor IsConstr
+          <*> inside "constr:constr" capitalName
+          <*> optional do
+                inside "arguments" tuple_pattern
+  <|>
+    do
+      ctor IsConstr
+         <*> do ctor Name <*> do token "True" <|> token "False" <|> token "None" <|> token "Unit"
+         <*> pure Nothing
+
+tuple_pattern :: Parser (Pattern ASTInfo)
+tuple_pattern = do
+  subtree "tuple_pattern" do
+    ctor IsTuple <*> do
+      many "element" do
+        inside "element" pattern
+
+list_pattern :: Parser (Pattern ASTInfo)
+list_pattern = do
+  subtree "list_pattern" do
+    ctor IsList <*> do
+      many "element" do
+        inside "element" pattern
+
+nullary_ctor :: Parser (Expr ASTInfo)
+nullary_ctor = do
+  ctor Ident <*> do
+    ctor QualifiedName
+      <*> do ctor Name <*> do
+               true <|> false <|> none <|> unit
+      <*> pure []
   where
-  -- $.case_expr,
+    true  = token "True"
-  -- $.cond_expr,
+    false = token "False"
-  -- $.disj_expr,
+    none  = token "None"
-  -- $.fun_expr,
+    unit  = token "Unit"
+
+nat_literal :: Parser (Expr ASTInfo)
+nat_literal = do
+  ctor Constant <*> do
+    ctor Nat <*> token "Nat"
+
+bytes_literal :: Parser (Expr ASTInfo)
+bytes_literal = do
+  ctor Constant <*> do
+    ctor Bytes <*> token "Bytes"
+
+constr_call :: Parser (Expr ASTInfo)
+constr_call = do
+  some_call <|> user_constr_call
+  where
+    some_call = do
+      subtree "Some_call" do
+        ctor Apply
+          <*> do ctor Ident <*> inside "constr" qname'
+          <*> inside "arguments:arguments" do
+            many "argument" do
+              inside "argument" expr
+
+    user_constr_call = do
+      subtree "constr_call" do
+        ctor Apply
+          <*> inside "constr:constr" do
+                ctor Ident <*> do
+                   ctor QualifiedName
+                     <*> capitalName
+                     <*> pure []
+          <*> inside "arguments:arguments" do
+            many "argument" do
+              inside "argument" expr
+
+indexing :: Parser (Expr ASTInfo)
+indexing = do
+  subtree "map_lookup" do
+    ctor Indexing
+      <*> inside "container:path" do
+            qname <|> projection
+      <*> inside "index" expr
 
 map_remove :: Parser (Expr ASTInfo)
 map_remove = do
@@ -117,7 +399,7 @@ map_remove = do
       <*> inside "key" expr
       <*> inside "container" do
         inside ":path" do
-          qname
+          qname <|> projection
 
 big_map_expr :: Parser (Expr ASTInfo)
 big_map_expr = do
@@ -148,7 +430,7 @@ moduleQualified = do
     ctor Ident <*> do
       ctor QualifiedName
         <*> inside "module" capitalName
-        <*> do pure <$> do ctor At <*> inside "method" name
+        <*> do pure <$> do ctor At <*> inside "method" do name <|> name'
 
 tuple_expr :: Parser (Expr ASTInfo)
 tuple_expr = do
@@ -191,6 +473,12 @@ qname = do
     <*> name
     <*> pure []
 
+qname' :: Parser (QualifiedName ASTInfo)
+qname' = do
+  ctor QualifiedName
+    <*> name'
+    <*> pure []
+
 assign :: Parser (Expr ASTInfo)
 assign = do
   subtree "assignment" do
@@ -230,17 +518,25 @@ if_expr = do
         <*> inside "selector"       expr
         <*> inside "then:if_clause" expr
         <*> inside "else:if_clause" expr
+  <|> do
+    subtree "cond_expr" do
+      ctor If
+        <*> inside "selector"       expr
+        <*> inside "then" expr
+        <*> inside "else" expr
 
 method_call :: Parser (Expr ASTInfo)
 method_call = do
   subtree "projection_call" do
-    ctor Apply
+    ctor apply'
-      <*> do ctor Ident <*> field "f" projection
+      <*> field "f" projection
-      <*> inside "arguments" arguments
+      <*> optional do inside "arguments" arguments
+  where
+    apply' r f (Just xs) = Apply r (Ident r f) xs
+    apply' r f _         = Ident r f
 
 projection :: Parser (QualifiedName ASTInfo)
 projection = do
-  gets pfGrove >>= traceShowM
   subtree "data_projection" do
     ctor QualifiedName
       <*> inside "struct" name
@@ -258,9 +554,12 @@ selection = do
 par_call :: Parser (Expr ASTInfo)
 par_call = do
   subtree "par_call" do
-    ctor Apply
+    ctor apply'
       <*> inside "f" expr
-      <*> inside "arguments" arguments
+      <*> optional do inside "arguments" arguments
+  where
+    apply' r f (Just xs) = Apply r f xs
+    apply' _ f  _        = f
 
 int_literal :: Parser (Expr ASTInfo)
 int_literal = do
@@ -296,7 +595,7 @@ function_id = select
       subtree "module_field" do
         ctor QualifiedName
           <*> inside "module" capitalName
-          <*> do pure <$> do ctor At <*> inside "method" name
+          <*> do pure <$> do ctor At <*> inside "method" do name <|> name'
   ]
 
 opCall :: Parser (Expr ASTInfo)
@@ -331,8 +630,7 @@ statement = ctor Action <*> expr
 
 paramDecl :: Parser (VarDecl ASTInfo)
 paramDecl = do
-  info <- getRange
+  subtree "param_decl" do
-  inside "parameter:param_decl" do
     ctor Decl
       <*> do inside ":access" do
               select
@@ -345,9 +643,21 @@ paramDecl = do
 newtype_ = select
   [ record_type
   , type_
-  -- , sum_type
+  , sum_type
   ]
 
+sum_type = do
+  subtree "sum_type" do
+    ctor TSum <*> do
+      many "variant" do
+        inside "variant" variant
+
+variant = do
+  subtree "variant" do
+    ctor Variant
+      <*> inside "constructor:constr" capitalName
+      <*> optional do inside "arguments" type_
+
 record_type = do
   subtree "record_type" do
     ctor TRecord
@@ -359,7 +669,7 @@ field_decl = do
   subtree "field_decl" do
     ctor TField
       <*> inside "fieldName" name
-      <*> inside "fieldType" type_
+      <*> inside "fieldType" newtype_
 
 type_ :: Parser (Type ASTInfo)
 type_ =
@@ -395,6 +705,8 @@ type_ =
             ctor TApply
               <*> inside "typeConstr" name'
               <*> do pure <$> inside "arguments" type_
+
+        , subtree "type_expr" newtype_
         ]
 
 name' :: Parser (Name ASTInfo)
@@ -417,12 +729,15 @@ typeTuple = do
 -- 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/big_map.ligo"
--- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/bitwise_arithmetic.ligo"
--- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/blockless.ligo"
--- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/boolean_operators.ligo"
--- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
--- example = "../../../src/test/contracts/application.ligo"
+-- example = "../../../src/test/contracts/bytes_unpack.ligo"
+-- example = "../../../src/test/contracts/chain_id.ligo"
+-- example = "../../../src/test/contracts/coase.ligo"
+example = "../../../src/test/contracts/failwith.ligo"
 -- example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/application.ligo"

tools/lsp/squirrel/src/AST/Types.hs

@@ -28,6 +28,7 @@ data Declaration info
   = ValueDecl info (Binding info)
   | TypeDecl  info (Name info) (Type info)
   | Action    info (Expr info)
+  | Include   info Text
   | WrongDecl      Error
   deriving (Show) via PP (Declaration info)
 
@@ -63,7 +64,7 @@ data Type info
   = TArrow    info  (Type info) (Type info)
   | TRecord   info [TField info]
   | TVar      info  (Name info)
-  | TSum      info [(Name info, [Type info])]
+  | TSum      info [Variant info]
   | TProduct  info  [Type info]
   | TApply    info  (Name info) [Type info]
   | WrongType      Error
@@ -71,6 +72,13 @@ data Type info
 
 instance Stubbed (Type info) where stub = WrongType
 
+data Variant info
+  = Variant info (Name info) (Maybe (Type info))
+  | WrongVariant Error
+  deriving (Show) via PP (Variant info)
+
+instance Stubbed (Variant info) where stub = WrongVariant
+
 data TField info
   = TField info (Name info) (Type info)
   | WrongTField Error
@@ -89,6 +97,7 @@ data Expr info
   | If        info (Expr info) (Expr info) (Expr info)
   | Assign    info (LHS info) (Expr info)
   | List      info [Expr info]
+  | Set       info [Expr info]
   | Tuple     info [Expr info]
   | Annot     info (Expr info) (Type info)
   | Attrs     info [Text]
@@ -96,11 +105,29 @@ data Expr info
   | Map       info [MapBinding info]
   | MapRemove info (Expr info) (QualifiedName info)
   | SetRemove info (Expr info) (QualifiedName info)
+  | Indexing  info (QualifiedName info) (Expr info)
+  | Case      info (Expr info) [Alt info]
+  | Skip      info
+  | ForLoop   info (Name info) (Expr info) (Expr info) (Expr info)
+  | WhileLoop info (Expr info) (Expr info)
+  | Seq       info [Declaration info]
+  | Lambda    info [VarDecl info] (Type info) (Expr info)
+  | ForBox    info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info)
+  | MapPatch  info (QualifiedName info) [MapBinding info]
+  | SetPatch  info (QualifiedName info) [Expr info]
+  | RecordUpd info (QualifiedName info) [FieldAssignment info]
   | WrongExpr      Error
   deriving (Show) via PP (Expr info)
 
 instance Stubbed (Expr info) where stub = WrongExpr
 
+data Alt info
+  = Alt info (Pattern info) (Expr info)
+  | WrongAlt Error
+  deriving (Show) via PP (Alt info)
+
+instance Stubbed (Alt info) where stub = WrongAlt
+
 data LHS info
   = LHS info (QualifiedName info) (Maybe (Expr info))
   | WrongLHS Error
@@ -122,8 +149,16 @@ data Assignment info
 
 instance Stubbed (Assignment info) where stub = WrongAssignment
 
+data FieldAssignment info
+  = FieldAssignment info (QualifiedName info) (Expr info)
+  | WrongFieldAssignment Error
+  deriving (Show) via PP (FieldAssignment info)
+
+instance Stubbed (FieldAssignment info) where stub = WrongFieldAssignment
+
 data Constant info
   = Int     info Text
+  | Nat     info Text
   | String  info Text
   | Float   info Text
   | Bytes   info Text
@@ -134,9 +169,13 @@ data Constant info
 instance Stubbed (Constant info) where stub = WrongConstant
 
 data Pattern info
-  = IsConstr     info (Name info) [Pattern info]
+  = IsConstr     info (Name info) (Maybe (Pattern info))
   | IsConstant   info (Constant info)
   | IsVar        info (Name info)
+  | IsCons       info (Pattern info) (Pattern info)
+  | IsWildcard   info
+  | IsList       info [Pattern info]
+  | IsTuple      info [Pattern info]
   | WrongPattern      Error
   deriving (Show) via PP (Pattern info)
 
@@ -188,6 +227,7 @@ instance Pretty (Declaration i) where
     ValueDecl _ binding -> pp binding
     TypeDecl  _ n ty    -> hang ("type" <+> pp n <+> "=") 2 (pp ty)
     Action    _ e       -> pp e
+    Include   _ f       -> "#include" <+> pp f
     WrongDecl err       -> pp err
 
 instance Pretty (Binding i) where
@@ -242,27 +282,32 @@ instance Pretty (Type i) where
     TArrow    _ dom codom -> parens (pp dom <+> "->" <+> pp codom)
     TRecord   _ fields    -> "record [" <> (vcat $ map pp fields) <> "]"
     TVar      _ name      -> pp name
-    TSum      _ variants  -> vcat $ map ppCtor variants
+    TSum      _ variants  -> vcat $ map pp variants
     TProduct  _ elements  -> fsep $ punctuate " *" $ map pp elements
     TApply    _ f xs      -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
     WrongType   err       -> pp err
     where
       ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
-      ppCtor  (ctor, fields) =
+
-        "|" <+> pp ctor <+> parens (fsep $ punctuate "," $ map pp fields)
+instance Pretty (Variant i) where
+  pp = \case
+    Variant _ ctor (Just ty) -> hang ("|" <+> pp ctor <+> "of") 2 (pp ty)
+    Variant _ ctor  _        -> "|" <+> pp ctor
+    WrongVariant err -> pp err
 
 instance Pretty (Expr i) where
   pp = \case
     Let       _ decls body -> "block {" $$ (nest 2 $ vcat $ punctuate "\n" $ map pp decls) $$ "}" $$ "with" $$ nest 2 (pp body)
-    Apply     _ f xs       -> pp f <> tuple xs
+    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)
     UnOp      _   o r      -> parens (pp o <+> pp r)
     Record    _ az         -> "record [" <> (fsep $ punctuate ";" $ map pp az) <> "]"
-    If        _ b t e      -> fsep ["if" <+> pp b, nest 2 $ "then" <+> pp t, nest 2 $ "else" <+> pp e]
+    If        _ b t e      -> fsep ["if" <+> pp b, hang "then" 2 $ pp t, hang "else" 2 $ pp e]
     Assign    _ l r        -> hang (pp l <+> ":=") 2 (pp r)
-    List      _ l          -> "[" <> fsep (punctuate ";" $ map pp l) <> "]"
+    List      _ l          -> "list [" <> fsep (punctuate ";" $ map pp l) <> "]"
+    Set       _ l          -> "set [" <> 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) <> "]"
@@ -270,8 +315,24 @@ instance Pretty (Expr i) where
     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)
+    Indexing  _ a i        -> pp a <> brackets (pp i)
+    Case      _ s az       -> hang ("case" <+> pp s <+> "of") 2 (vcat $ map pp az)
+    Skip      _            -> "skip"
+    ForLoop   _ i s f b    -> hang ("for" <+> pp i <+> ":=" <+> pp s <+> "to" <+> pp f) 2 (pp b)
+    ForBox    _ k mv t c b -> hang ("for" <+> (pp k <> maybe empty ((" ->" <+>) . pp) mv) <+> "in" <+> pp t <+> pp c) 2 (pp b)
+    WhileLoop _ f b        -> hang ("while" <+> pp f) 2 (pp b)
+    Seq       _ es         -> hang (hang "block {" 2 (vcat $ map pp es)) 0 "}"
+    Lambda    _ ps ty b    -> parens (hang ("function" <+> ("(" <> fsep (punctuate "," $ map pp ps) <> ") :") <+> pp ty) 2 (pp b))
+    MapPatch  _ c bs       -> hang (hang "patch" 2 (pp c)) 0 (hang ("with" <+> "map") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]"))
+    SetPatch  _ c bs       -> hang (hang "patch" 2 (pp c)) 0 (hang ("with" <+> "set") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]"))
+    RecordUpd _ r up       -> hang (pp r) 2 (hang ("with" <+> "record") 2 ("[" <> fsep (punctuate ";" $ map pp up) <> "]"))
     WrongExpr   err        -> pp err
 
+instance Pretty (Alt info) where
+  pp = \case
+    Alt _ p b -> hang ("|" <+> pp p <+> "->") 2 (pp b)
+    WrongAlt err -> pp err
+
 instance Pretty (MapBinding i) where
   pp = \case
     MapBinding _ k v -> hang (pp k <+> "->") 2 (pp v)
@@ -282,9 +343,15 @@ instance Pretty (Assignment i) where
     Assignment      _ n e -> pp n <+> "=" <+> pp e
     WrongAssignment   err -> pp err
 
+instance Pretty (FieldAssignment i) where
+  pp = \case
+    FieldAssignment      _ n e -> pp n <+> "=" <+> pp e
+    WrongFieldAssignment   err -> pp err
+
 instance Pretty (Constant i) where
   pp = \case
     Int           _ c   -> pp c
+    Nat           _ c   -> pp c
     String        _ c   -> pp c
     Float         _ c   -> pp c
     Bytes         _ c   -> pp c
@@ -298,9 +365,13 @@ instance Pretty (QualifiedName i) where
 
 instance Pretty (Pattern info) where
   pp = \case
-    IsConstr     _ ctor args -> pp ctor <> tuple args
+    IsConstr     _ ctor arg  -> pp ctor <> maybe empty pp arg
     IsConstant   _ c         -> pp c
     IsVar        _ name      -> pp name
+    IsCons       _ h t       -> pp h <+> "#" <+> pp t
+    IsWildcard   _           -> "_"
+    IsList       _ l         -> "[" <> fsep (punctuate ";" $ map pp l) <> "]"
+    IsTuple      _ t         -> "(" <> fsep (punctuate "," $ map pp t) <> ")"
     WrongPattern   err       -> pp err
 
 

tools/lsp/squirrel/src/Parser.hs

@@ -30,7 +30,7 @@ data Error
   deriving stock (Show)
 
 instance Pretty Error where
-  pp (Expected msg found r) = "<<<" <> pp msg <> pp r <> ": " <> pp found <> ">>>"
+  pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓"
 
 newtype Parser a = Parser
   { unParser
@@ -318,3 +318,6 @@ data ASTInfo = ASTInfo
 
 ctor :: (ASTInfo -> a) -> Parser a
 ctor = (<$> (ASTInfo <$> getRange <*> pure []))
+
+dump :: Parser ()
+dump = gets pfGrove >>= traceShowM