diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index d5780a779..5ed8320d2 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -26,6 +26,7 @@ import System.Exit import qualified System.Log as L import Duplo.Error +import Duplo.Pretty import Duplo.Tree (collect) import Range diff --git a/tools/lsp/squirrel/grammar/camligo/grammar.js b/tools/lsp/squirrel/grammar/camligo/grammar.js index 1f29212c3..e3d9fb638 100644 --- a/tools/lsp/squirrel/grammar/camligo/grammar.js +++ b/tools/lsp/squirrel/grammar/camligo/grammar.js @@ -95,7 +95,7 @@ module.exports = grammar({ )), _pattern: $ => choice( - $.Name, + $.var_pattern, $._paren_pattern, $.con_pattern, $._literal, @@ -105,6 +105,10 @@ module.exports = grammar({ "_" ), + var_pattern: $ => seq( + field("var", $.Name) + ), + con_pattern: $ => prec(10, seq( field("ctor", $.data_con), diff --git a/tools/lsp/squirrel/src/AST/Camligo/Parser.hs b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs index 60ce06279..62f0baf75 100644 --- a/tools/lsp/squirrel/src/AST/Camligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs @@ -66,7 +66,7 @@ example :: FilePath -- example = "../../../src/test/contracts/lambda2.mligo" -- example = "../../../src/test/contracts/loop.mligo" -- example = "../../../src/test/contracts/let_in_multi_bind.mligo" -example = "../../../src/test/contracts/list.mligo" +example = "../../../src/test/contracts/fibo2.mligo" raw :: IO () raw = toParseTree (Path example) @@ -137,6 +137,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope "con_pattern" -> IsConstr <$> field "ctor" <*> fieldOpt "args" "annot_pattern" -> IsAnnot <$> field "pat" <*> field "type" "paren_pattern" -> IsTuple <$> fields "pat" + "var_pattern" -> IsVar <$> field "var" "_" -> pure IsWildcard _ -> fallthrough diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index ea463b027..b2d5483e3 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -74,7 +74,7 @@ instance {-# OVERLAPS #-} Pretty FullEnv where mergeFE fe = getTag @"vars" @Env fe Prelude.<> getTag @"types" fe instance Pretty ScopedDecl where - pp (ScopedDecl n o _ t refs doc) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs `indent` pp doc + pp (ScopedDecl n o _ t refs doc) = color 3 (pp n) <+> pp o <+> ":" <+> maybe "?" (either pp pp) t <+> "=" <+> pp refs `indent` pp doc instance Pretty Kind where pp _ = "TYPE" diff --git a/tools/lsp/squirrel/src/AST/Skeleton.hs b/tools/lsp/squirrel/src/AST/Skeleton.hs index 3dc39f1b6..a89ba2b61 100644 --- a/tools/lsp/squirrel/src/AST/Skeleton.hs +++ b/tools/lsp/squirrel/src/AST/Skeleton.hs @@ -228,6 +228,12 @@ newtype FieldName it = FieldName Text deriving (Show) via PP (TypeName it) deriving stock (Functor, Foldable, Traversable) +sexpr :: Text -> [Doc] -> Doc +sexpr header items = "(" <.> pp header `indent` foldr above empty items <.> ")" + +sop :: Doc -> Text -> [Doc] -> Doc +sop a op b = "(" <.> a `indent` pp op `indent` foldr above empty b <.> ")" + instance Pretty1 Language where pp1 = \case Language _ p -> p @@ -238,43 +244,38 @@ instance Pretty1 Undefined where instance Pretty1 Contract where pp1 = \case - ContractEnd -> "(* end *)" - ContractCons x xs -> x $$ " " $$ xs + ContractEnd -> "(endtract)" + ContractCons x xs -> sexpr "constract" [x, xs] instance Pretty1 RawContract where pp1 = \case - RawContract xs -> "(* begin *)" `indent` sparseBlock xs `above` "(* end *)" + RawContract xs -> sexpr "contract" xs instance Pretty1 Binding where pp1 = \case - Irrefutable pat expr -> "irref" <+> pat <+> "=" `indent` expr - TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty - -- TODO - Var name ty value -> "var" <+> name <+> ":" <+> fromMaybe "" ty <+> ":=" `indent` value - Const name ty body -> "const" <+> name <+> ":" <+> pp ty <+> "=" `indent` body - Attribute name -> "[@" <.> name <.> "]" - Include fname -> "#include" <+> fname + Irrefutable pat expr -> sexpr "irref" [pat, expr] + TypeDecl n ty -> sexpr "type" [n, ty] + Var name ty value -> sexpr "var" [name, pp ty, value] + Const name ty body -> sexpr "const" [name, pp ty, body] + Attribute name -> sexpr "attr" [name] + Include fname -> sexpr "#include" [fname] Function isRec name params ty body -> - ( - ( - ( (if isRec then "recursive" else empty) - <+> "function" - <+> name - ) - `indent` pp params - ) - `indent` (":" <+> pp ty `above` "is") - ) - `indent` body + sexpr "fun" $ concat + [ ["rec" | isRec] + , [name] + , params + , [":", pp ty] + , ["=", body] + ] instance Pretty1 Parameters where pp1 = \case - Parameters them -> tuple them + Parameters them -> sexpr "params" them instance Pretty1 VarDecl where pp1 = \case - Decl mutability name ty -> mutability <+> name <+> ":" `indent` ty + Decl mutability name ty -> sexpr "decl" [mutability, name, ty] instance Pretty1 Mutable where pp1 = \case @@ -283,79 +284,74 @@ instance Pretty1 Mutable where instance Pretty1 Type where pp1 = \case - TArrow dom codom -> parens (dom `indent` "->" <+> codom) - TRecord fields -> "record [" `indent` block fields `above` "]" + TArrow dom codom -> sop dom "->" [codom] + TRecord fields -> sexpr "RECORD" fields TVar name -> name - TSum variants -> block variants - TProduct elements -> train " *" elements - TApply f xs -> f <+> tuple xs - TTuple xs -> tuple xs - TOr l n r m -> "michelson_or" <+> tuple [l, n, r, m] - TAnd l n r m -> "michelson_pair" <+> tuple [l, n, r, m] + TSum variants -> sexpr "SUM" variants + TProduct elements -> sexpr "PROD" elements + TApply f xs -> sop f "$" xs + TTuple xs -> sexpr "TUPLE" xs + TOr l n r m -> sexpr "OR" [l, n, r, m] + TAnd l n r m -> sexpr "AND" [l, n, r, m] instance Pretty1 Variant where pp1 = \case - Variant ctor (Just ty) -> "|" <+> ctor <+> "of" `indent` ty - Variant ctor _ -> "|" <+> ctor + Variant ctor ty -> sexpr "ctor" [ctor, pp ty] instance Pretty1 ReasonExpr where pp1 = \case - -- TODO: prettify - Block decls ret -> "block' {" - `indent` block decls - <+> (if null decls then "" else ";") - `above` maybe "" ("return" `indent`) ret `above` "}" + Block decls ret -> sexpr "block" $ decls ++ [pp ret] instance Pretty1 Expr where pp1 = \case - Let decl body -> "let" <+> decl `above` body - Apply f xs -> "(" <.> f <.> ")" `indent` xs + Let decl body -> sexpr "let" [decl, body] + Apply f xs -> sexpr "apply" [f, xs] Constant constant -> constant Ident qname -> qname - BinOp l o r -> parens (l <+> pp o <+> r) - UnOp o r -> parens (pp o <+> r) + BinOp l o r -> sop l (ppToText o) [r] + UnOp o r -> sexpr (ppToText o) [r] Op o -> pp o - Record az -> "record" <+> list az - If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` pp e] - Assign l r -> l <+> ":=" `indent` r - List l -> "list" <+> list l - ListAccess l ids -> l <.> cat ((("[" <.>) . (<.> "]") . pp) <$> ids) - Set l -> "set" <+> list l - Tuple l -> tuple l - Annot n t -> parens (n <+> ":" `indent` t) - Attrs ts -> "attributes" <+> list ts - BigMap bs -> "big_map" <+> list bs - Map bs -> "map" <+> list bs - MapRemove k m -> "remove" `indent` k `above` "from" <+> "map" `indent` m - SetRemove k s -> "remove" `indent` k `above` "from" <+> "set" `indent` s - Indexing a j -> a <.> list [j] - Case s az -> "case" <+> s <+> "of" `indent` block az + Record az -> sexpr "record" az + If b t e -> sexpr "if" [b, t, pp e] + Assign l r -> sop l ":=" [r] + List l -> sexpr "list" l + ListAccess l ids -> sexpr "get" (l : ids) + Set l -> sexpr "set" l + Tuple l -> sexpr "tuple" l + Annot n t -> sop n ":" [t] + Attrs ts -> sexpr "attrs" ts + BigMap bs -> sexpr "big_map" bs + Map bs -> sexpr "map" bs + MapRemove k m -> sexpr "remove_map" [k, m] + SetRemove k s -> sexpr "remove_set" [k, s] + Indexing a j -> sexpr "index" [a, j] + Case s az -> sexpr "case" (s : az) Skip -> "skip" - ForLoop j s f d b -> "for" <+> j <+> ":=" <+> s <+> "to" <+> f <+> mb ("step" <+>) d `indent` b - ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b - WhileLoop f b -> "while" <+> f `indent` b - Seq es -> "block {" `indent` block es `above` "}" - Lambda ps ty b -> (("lam" `indent` pp ps) `indent` (":" <+> fromMaybe "" ty)) `indent` "=>" `indent` b - MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs - SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs - RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up + ForLoop j s f d b -> sexpr "for" [j, s, f, pp d, b] + ForBox k mv t z b -> sexpr "for_box" [k, pp mv, pp t, z, b] + WhileLoop f b -> sexpr "while" [f, b] + Seq es -> sexpr "seq" es + Lambda ps ty b -> sexpr "lam" $ concat [ps, [":", pp ty], ["=>", b]] + MapPatch z bs -> sexpr "patch" (z : bs) + SetPatch z bs -> sexpr "patch_set" (z : bs) + RecordUpd r up -> sexpr "update" (r : up) instance Pretty1 Alt where pp1 = \case - Alt p b -> "|" <+> p <+> "->" `indent` b + Alt p b -> sexpr "alt" [p, b] instance Pretty1 MapBinding where pp1 = \case - MapBinding k v -> k <+> "->" `indent` v + MapBinding k v -> sexpr "bind" [k, v] instance Pretty1 Assignment where pp1 = \case - Assignment n e -> n <+> "=" `indent` e + Assignment n e -> sexpr "assign" [n, e] instance Pretty1 FieldAssignment where pp1 = \case - FieldAssignment n e -> n <+> "=" `indent` e - Spread n -> "..." <+> n + FieldAssignment n e -> sexpr ".=" [n, e] + Spread n -> sexpr "..." [n] instance Pretty1 Constant where pp1 = \case @@ -368,34 +364,34 @@ instance Pretty1 Constant where instance Pretty1 QualifiedName where pp1 = \case - QualifiedName src path -> src <.> sepByDot path + QualifiedName src path -> sexpr "." (src : path) instance Pretty1 Pattern where pp1 = \case - IsConstr ctor arg -> ctor <+> maybe empty id arg - IsConstant z -> z - IsVar name -> name - IsCons h t -> h <+> ("#" <+> t) - IsAnnot s t -> "(" <+> s <+> ":" <+> t <+> ")" - IsWildcard -> "_" - IsList l -> list l - IsTuple t -> tuple t + IsConstr ctor arg -> sexpr "ctor?" [ctor, pp arg] + IsConstant z -> sexpr "is?" [z] + IsVar name -> sexpr "?" [name] + IsCons h t -> sop h "::?" [t] + IsAnnot s t -> sexpr "type?" [s, t] + IsWildcard -> "_?" + IsList l -> sexpr "list?" l + IsTuple t -> sexpr "tuple?" t instance Pretty1 Name where pp1 = \case - Name raw -> pp raw + Name raw -> color 2 $ pp raw instance Pretty1 TypeName where pp1 = \case - TypeName raw -> pp raw + TypeName raw -> color 3 $ pp raw instance Pretty1 FieldName where pp1 = \case - FieldName raw -> pp raw + FieldName raw -> color 4 $ pp raw instance Pretty1 Ctor where pp1 = \case - Ctor raw -> pp raw + Ctor raw -> color 5 $ pp raw instance Pretty1 Path where pp1 = \case