diff --git a/tools/lsp/pascaligo/grammar.js b/tools/lsp/pascaligo/grammar.js index 5583a2eae..fb206f37c 100644 --- a/tools/lsp/pascaligo/grammar.js +++ b/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)/, diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 65291fac8..ed00acd15 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/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) - putStrLn "" - putStrLn "Errors:" - for_ errs (print . nest 2 . pp) \ No newline at end of file + unless (null errs) do + putStrLn "" + putStrLn "Errors:" + for_ errs (print . nest 2 . pp) \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 7363e7ce7..91092502f 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/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 "type:" type_ - <*> inside "value:" expr + <*> inside "name" name + <*> inside "type" type_ + <*> 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 - consumeOrDie ")" - - stubbed "parameters" paramDecl + inside "parameter" 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, - -- $.cond_expr, - -- $.disj_expr, - -- $.fun_expr, + true = token "True" + false = token "False" + none = token "None" + 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 @@ -225,22 +513,30 @@ tez_literal = do if_expr :: Parser (Expr ASTInfo) if_expr = do - subtree "conditional" do - ctor If - <*> inside "selector" expr - <*> inside "then:if_clause" expr - <*> inside "else:if_clause" expr + subtree "conditional" do + ctor If + <*> 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 - <*> do ctor Ident <*> field "f" projection - <*> inside "arguments" arguments + ctor apply' + <*> field "f" projection + <*> 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 - inside "parameter:param_decl" do + subtree "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/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/big_map.ligo" +-- example = "../../../src/test/contracts/bitwise_arithmetic.ligo" +-- example = "../../../src/test/contracts/blockless.ligo" +-- example = "../../../src/test/contracts/boolean_operators.ligo" +-- example = "../../../src/test/contracts/bytes_arithmetic.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" diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index 5f00db719..e28d35a47 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 5b9ad2456..05340a3bb 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/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