diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index a431fd9ca..4c9ee24b8 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -27,6 +27,7 @@ import ParseTree import Parser import Range import AST +import HasErrors import Pretty main :: IO () diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index c95d23222..7e2df4fe5 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -4,29 +4,38 @@ dependencies: - base - bytestring - data-default + - data-fix - lens - mtl + - pretty - template-haskell - text - tree-sitter - - pretty default-extensions: - - LambdaCase + - BangPatterns - BlockArguments - - OverloadedStrings - - GeneralisedNewtypeDeriving + - DataKinds + - DeriveFoldable + - DeriveFunctor + - DeriveTraversable - DerivingStrategies - DerivingVia + - FlexibleContexts - FlexibleInstances + - GADTs + - GeneralisedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses - NamedFieldPuns - - BangPatterns - - ScopedTypeVariables + - OverloadedStrings - QuasiQuotes + - ScopedTypeVariables + - StandaloneDeriving - TemplateHaskell - - DeriveFunctor - - DeriveFoldable - - DeriveTraversable + - TypeFamilies + - TypeOperators + - UndecidableInstances ghc-options: -freverse-errors -Wall -threaded diff --git a/tools/lsp/squirrel/squirrel.cabal b/tools/lsp/squirrel/squirrel.cabal index 0d298d516..aa05ce6db 100644 --- a/tools/lsp/squirrel/squirrel.cabal +++ b/tools/lsp/squirrel/squirrel.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: e30e95968ee812129049606c1bdd5ab3a97ce79d1da5f70f38adaf4bc91f4a4a +-- hash: fc91e2bbafd609769dba91a90992c659e68f017fa28f156cd261cd553083a47d name: squirrel version: 0.0.0 @@ -17,16 +17,20 @@ library AST.Parser AST.Scope AST.Types + Lattice Parser ParseTree Pretty Range TH + Tree + Union + Update other-modules: Paths_squirrel hs-source-dirs: src/ - default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell DeriveFunctor DeriveFoldable DeriveTraversable + default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances ghc-options: -freverse-errors -Wall -threaded include-dirs: vendor @@ -36,6 +40,7 @@ library base , bytestring , data-default + , data-fix , lens , mtl , pretty @@ -50,12 +55,13 @@ executable squirrel Paths_squirrel hs-source-dirs: app/ - default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell DeriveFunctor DeriveFoldable DeriveTraversable + default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances ghc-options: -freverse-errors -Wall -threaded build-depends: base , bytestring , data-default + , data-fix , haskell-lsp , hslogger , interpolate diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index f80972b04..be1fd9fbb 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/tools/lsp/squirrel/src/AST.hs @@ -3,5 +3,4 @@ module AST (module M) where import AST.Types as M import AST.Parser as M -import AST.Errors as M import AST.Scope as M diff --git a/tools/lsp/squirrel/src/AST/Errors.hs b/tools/lsp/squirrel/src/AST/Errors.hs deleted file mode 100644 index 96a82fc7d..000000000 --- a/tools/lsp/squirrel/src/AST/Errors.hs +++ /dev/null @@ -1,292 +0,0 @@ - -{- - The AST and auxillary types along with their pretty-printers. - - TODO: Untangle pretty-printing mess into combinators. - TODO: Store offending text verbatim in Wrong*. --} - -module AST.Errors where - -import Parser -import AST.Types - -class HasErrors h where - errors :: h -> [Error] - -instance {-# OVERLAPPABLE #-} (HasErrors a, Foldable f) => HasErrors (f a) where - errors = foldMap errors - -instance HasErrors (Contract i) where - errors = \case - Contract _ ds -> errors ds - WrongContract err -> return err - --- data Contract info --- = Contract info [Declaration info] --- | WrongContract Error - -instance HasErrors (Declaration i) where - errors = \case - ValueDecl _ bind -> errors bind - TypeDecl _ n ty -> errors n <> errors ty - Action _ e -> errors e - Include _ _ -> fail "text" - WrongDecl err -> return err - --- data Declaration info --- = ValueDecl info (Binding info) --- | TypeDecl info (Name info) (Type info) --- | Action info (Expr info) --- | Include info Text --- | WrongDecl Error - -instance HasErrors (Binding i) where - errors = \case - Irrefutable _ a b -> errors a <> errors b - Function _ _ a b c d -> errors a <> errors b <> errors c <> errors d - Var _ a b c -> errors a <> errors b <> errors c - Const _ a b c -> errors a <> errors b <> errors c - WrongBinding e -> return e - --- data Binding info --- = Irrefutable info (Pattern info) (Expr info) --- | Function info Bool (Name info) [VarDecl info] (Type info) (Expr info) --- | Var info (Name info) (Type info) (Expr info) --- | Const info (Name info) (Type info) (Expr info) --- | WrongBinding Error - -instance HasErrors (VarDecl i) where - errors = \case - Decl _ a b c -> errors a <> errors b <> errors c - WrongVarDecl e -> return e - --- data VarDecl info --- = Decl info (Mutable info) (Name info) (Type info) --- | WrongVarDecl Error - -instance HasErrors (Mutable i) where - errors = \case - WrongMutable e -> return e - _ -> fail "none" - --- data Mutable info --- = Mutable info --- | Immutable info --- | WrongMutable Error - -instance HasErrors (Type i) where - errors = \case - TArrow _ a b -> errors a <> errors b - TRecord _ fs -> errors fs - TVar _ a -> errors a - TSum _ cs -> errors cs - TProduct _ es -> errors es - TApply _ f xs -> errors f <> errors xs - --- data Type info --- = TArrow info (Type info) (Type info) --- | TRecord info [TField info] --- | TVar info (Name info) --- | TSum info [Variant info] --- | TProduct info [Type info] --- | TApply info (Name info) [Type info] --- | WrongType Error - -instance HasErrors (Variant i) where - errors = \case - Variant _ a b -> errors a <> errors b - WrongVariant e -> return e - --- data Variant info --- = Variant info (Name info) (Maybe (Type info)) --- | WrongVariant Error - -instance HasErrors (TField i) where - errors = \case - TField _ a b -> errors a <> errors b - WrongTField e -> return e - --- data TField info --- = TField info (Name info) (Type info) --- | WrongTField Error - -instance HasErrors (Expr i) where - errors = \case - Let _ ds b -> errors ds <> errors b - Apply _ f xs -> errors f <> errors xs - Constant _ c -> errors c - Ident _ q -> errors q - BinOp _ l _ r -> errors l <> errors r - UnOp _ _ o -> errors o - Record _ fs -> errors fs - If _ a b c -> errors a <> errors b <> errors c - Assign _ a b -> errors a <> errors b - List _ l -> errors l - Set _ l -> errors l - Tuple _ l -> errors l - Annot _ a b -> errors a <> errors b - Attrs _ _ -> fail "none" - BigMap _ l -> errors l - Map _ l -> errors l - MapRemove _ a b -> errors a <> errors b - SetRemove _ a b -> errors a <> errors b - Indexing _ a b -> errors a <> errors b - Case _ a bs -> errors a <> errors bs - Skip _ -> fail "none" - ForLoop _ a b c d -> errors a <> errors b <> errors c <> errors d - WhileLoop _ a b -> errors a <> errors b - Seq _ ds -> errors ds - Lambda _ ps b c -> errors ps <> errors b <> errors c - ForBox _ a b _ c d -> errors a <> errors b <> errors c <> errors d - MapPatch _ a bs -> errors a <> errors bs - SetPatch _ a bs -> errors a <> errors bs - RecordUpd _ a bs -> errors a <> errors bs - WrongExpr e -> return e - --- data Expr info --- = Let info [Declaration info] (Expr info) --- | Apply info (Expr info) [Expr info] --- | Constant info (Constant info) --- | Ident info (QualifiedName info) --- | BinOp info (Expr info) Text (Expr info) --- | UnOp info Text (Expr info) --- | Record info [Assignment 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] --- | BigMap info [MapBinding 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 - -instance HasErrors (Alt i) where - errors = \case - Alt _ a b -> errors a <> errors b - WrongAlt e -> return e - --- data Alt info --- = Alt info (Pattern info) (Expr info) --- | WrongAlt Error - -instance HasErrors (LHS i) where - errors = \case - LHS _ a b -> errors a <> errors b - WrongLHS e -> return e - --- data LHS info --- = LHS info (QualifiedName info) (Maybe (Expr info)) --- | WrongLHS Error - -instance HasErrors (MapBinding i) where - errors = \case - MapBinding _ a b -> errors a <> errors b - WrongMapBinding e -> return e - --- data MapBinding info --- = MapBinding info (Expr info) (Expr info) --- | WrongMapBinding Error - -instance HasErrors (Assignment i) where - errors = \case - Assignment _ a b -> errors a <> errors b - WrongAssignment e -> return e - --- data Assignment info --- = Assignment info (Name info) (Expr info) --- | WrongAssignment Error - -instance HasErrors (FieldAssignment i) where - errors = \case - FieldAssignment _ a b -> errors a <> errors b - WrongFieldAssignment e -> return e - --- data FieldAssignment info --- = FieldAssignment info (QualifiedName info) (Expr info) --- | WrongFieldAssignment Error - -instance HasErrors (Constant i) where - errors = \case - WrongConstant e -> return e - _ -> fail "none" - --- data Constant info --- = Int info Text --- | Nat info Text --- | String info Text --- | Float info Text --- | Bytes info Text --- | Tez info Text --- | WrongConstant Error - -instance HasErrors (Pattern i) where - errors = \case - IsConstr _ a b -> errors a <> errors b - IsConstant _ c -> errors c - IsVar _ a -> errors a - IsCons _ a b -> errors a <> errors b - IsWildcard _ -> fail "none" - IsList _ l -> errors l - IsTuple _ l -> errors l - WrongPattern e -> return e - --- data 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 - -instance HasErrors (QualifiedName i) where - errors = \case - QualifiedName _ a b -> errors a <> errors b - WrongQualifiedName e -> return e - --- data QualifiedName info --- = QualifiedName --- { qnInfo :: info --- , qnSource :: Name info --- , qnPath :: [Path info] --- } --- | WrongQualifiedName Error - -instance HasErrors (Path i) where - errors = \case - At _ a -> errors a - Ix _ _ -> fail "none" - WrongPath e -> return e - --- data Path info --- = At info (Name info) --- | Ix info Text --- | WrongPath Error - -instance HasErrors (Name i) where - errors = \case - WrongName e -> return e - _ -> fail "none" - --- data Name info = Name --- { info :: info --- , raw :: Text --- } --- | WrongName Error diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index d439163b0..cca01d390 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -15,71 +15,91 @@ import AST.Types hiding (tuple) import Parser import Range +import Tree +import Union import Debug.Trace -contract :: Parser (Contract ASTInfo) +ranged + :: ( Functor f + , Member f fs + ) + => Parser (f (Tree fs ASTInfo)) + -> Parser (Tree fs ASTInfo) +ranged p = do + r <- getInfo + a <- p + return $ mk r a + +contract :: Parser (Pascal ASTInfo) contract = - ctor Contract - <*> subtree "contract" do - many do - inside "declaration:" do - declaration + ranged do + pure Contract + <*> subtree "contract" do + many do + inside "declaration:" do + declaration -name :: Parser (Name ASTInfo) -name = ctor Name <*> token "Name" +name :: Parser (Pascal ASTInfo) +name = ranged do pure Name <*> token "Name" -capitalName :: Parser (Name ASTInfo) -capitalName = ctor Name <*> token "Name_Capital" +capitalName :: Parser (Pascal ASTInfo) +capitalName = ranged do pure Name <*> token "Name_Capital" -declaration :: Parser (Declaration ASTInfo) +declaration :: Parser (Pascal ASTInfo) declaration - = do ctor ValueDecl <*> binding - <|> do ctor ValueDecl <*> vardecl - <|> do ctor ValueDecl <*> constdecl + = do ranged do pure ValueDecl <*> binding + <|> do ranged do pure ValueDecl <*> vardecl + <|> do ranged do pure ValueDecl <*> constdecl <|> do typedecl - <|> do ctor Action <*> attributes + <|> do ranged do pure Action <*> attributes <|> do include include = do subtree "include" do - ctor Include - <*> inside "filename" do token "String" + ranged do + pure Include + <*> inside "filename" do + token "String" -typedecl :: Parser (Declaration ASTInfo) +typedecl :: Parser (Pascal ASTInfo) typedecl = do subtree "type_decl" do - ctor TypeDecl - <*> inside "typeName:" name - <*> inside "typeValue:" newtype_ + ranged do + pure TypeDecl + <*> inside "typeName:" name + <*> inside "typeValue:" newtype_ -vardecl :: Parser (Binding ASTInfo) +vardecl :: Parser (Pascal ASTInfo) vardecl = do subtree "var_decl" do - ctor Var - <*> inside "name" name - <*> inside "type" type_ - <*> inside "value" expr + ranged do + pure Var + <*> inside "name" name + <*> inside "type" type_ + <*> inside "value" expr -constdecl :: Parser (Binding ASTInfo) +constdecl :: Parser (Pascal ASTInfo) constdecl = do subtree "const_decl" do - ctor Const - <*> inside "name" name - <*> inside "type" type_ - <*> inside "value" expr + ranged do + pure Const + <*> inside "name" name + <*> inside "type" type_ + <*> inside "value" expr -binding :: Parser (Binding ASTInfo) +binding :: Parser (Pascal ASTInfo) binding = do inside ":fun_decl" do - ctor Function - <*> recursive - <*> inside "name:" name - <*> inside "parameters:parameters" do - many do - inside "parameter" paramDecl - <*> inside "type:" type_ - <*> inside "body:" letExpr + ranged do + pure Function + <*> recursive + <*> inside "name:" name + <*> inside "parameters:parameters" do + many do + inside "parameter" paramDecl + <*> inside "type:" type_ + <*> inside "body:" letExpr recursive = do mr <- optional do @@ -88,14 +108,16 @@ recursive = do return $ maybe False (== "recursive") mr -expr :: Parser (Expr ASTInfo) +expr :: Parser (Pascal ASTInfo) expr = stubbed "expr" do select [ -- Wait, isn't it `qname`? TODO: replace. - ctor Ident <*> do - ctor QualifiedName - <*> name - <*> pure [] + ranged do + pure Ident <*> do + ranged do + pure QualifiedName + <*> name + <*> pure [] , opCall , fun_call , record_expr @@ -133,58 +155,67 @@ expr = stubbed "expr" do , set_remove ] -set_remove :: Parser (Expr ASTInfo) +set_remove :: Parser (Pascal ASTInfo) set_remove = do subtree "set_remove" do - ctor SetRemove - <*> inside "key" expr - <*> inside "container" do - inside ":path" do - qname <|> projection + ranged do + pure SetRemove + <*> inside "key" expr + <*> inside "container" do + inside ":path" do + qname <|> projection +set_patch :: Parser (Pascal ASTInfo) set_patch = do subtree "set_patch" do - ctor SetPatch - <*> inside "container:path" (qname <|> projection) - <*> many do inside "key" expr + ranged do + pure SetPatch + <*> inside "container:path" (qname <|> projection) + <*> many do inside "key" expr record_update = do subtree "update_record" do - ctor RecordUpd - <*> inside "record:path" do qname <|> projection - <*> many do inside "assignment" field_path_assignment + ranged do + pure RecordUpd + <*> inside "record:path" do qname <|> projection + <*> many 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 + ranged do + pure 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 do inside "binding" map_binding + ranged do + pure MapPatch + <*> inside "container:path" (qname <|> projection) + <*> many do inside "binding" map_binding -set_expr :: Parser (Expr ASTInfo) +set_expr :: Parser (Pascal ASTInfo) set_expr = do subtree "set_expr" do - ctor List <*> many do - inside "element" expr + ranged do + pure List <*> many do + inside "element" expr lambda_expr = do subtree "fun_expr" do - ctor Lambda - <*> inside "parameters:parameters" do - many do inside "parameter" paramDecl - <*> inside "type" newtype_ - <*> inside "body" expr + ranged do + pure Lambda + <*> inside "parameters:parameters" do + many do inside "parameter" paramDecl + <*> inside "type" newtype_ + <*> inside "body" expr seq_expr = do subtree "block" do - ctor Seq <*> many do - inside "statement" do - declaration <|> statement + ranged do + pure Seq <*> many do + inside "statement" do + declaration <|> statement loop = do subtree "loop" do @@ -192,81 +223,93 @@ loop = do 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) + ranged do + pure 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 + ranged do + pure 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 + ranged do + pure 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 do - inside "statement" (declaration <|> statement) + ranged do + pure Seq <*> many do + inside "statement" (declaration <|> statement) <|> do subtree "clause_block" do - ctor Seq <*> many do - inside "statement" (declaration <|> statement) + ranged do + pure Seq <*> many do + inside "statement" (declaration <|> statement) -skip :: Parser (Expr ASTInfo) +skip :: Parser (Pascal ASTInfo) skip = do - ctor Skip <* token "skip" + ranged do + pure Skip + <* token "skip" -case_action :: Parser (Expr ASTInfo) +case_action :: Parser (Pascal ASTInfo) case_action = do subtree "case_instr" do - ctor Case - <*> inside "subject" expr - <*> many do - inside "case" alt_action + ranged do + pure Case + <*> inside "subject" expr + <*> many do + inside "case" alt_action -alt_action :: Parser (Alt ASTInfo) +alt_action :: Parser (Pascal ASTInfo) alt_action = do subtree "case_clause_instr" do - ctor Alt - <*> inside "pattern" pattern - <*> inside "body:if_clause" expr + ranged do + pure Alt + <*> inside "pattern" pattern + <*> inside "body:if_clause" expr -case_expr :: Parser (Expr ASTInfo) +case_expr :: Parser (Pascal ASTInfo) case_expr = do subtree "case_expr" do - ctor Case - <*> inside "subject" expr - <*> many do - inside "case" alt + ranged do + pure Case + <*> inside "subject" expr + <*> many do + inside "case" alt -alt :: Parser (Alt ASTInfo) +alt :: Parser (Pascal ASTInfo) alt = do subtree "case_clause_expr" do - ctor Alt - <*> inside "pattern" pattern - <*> inside "body" expr + ranged do + pure Alt + <*> inside "pattern" pattern + <*> inside "body" expr -pattern :: Parser (Pattern ASTInfo) +pattern :: Parser (Pascal ASTInfo) pattern = do subtree "pattern" $ do inside "the" core_pattern <|> - do ctor IsCons - <*> inside "head" core_pattern - <*> inside "tail" pattern + do ranged do + pure IsCons + <*> inside "head" core_pattern + <*> inside "tail" pattern -core_pattern :: Parser (Pattern ASTInfo) +core_pattern :: Parser (Pascal ASTInfo) core_pattern = constr_pattern <|> string_pattern @@ -277,350 +320,425 @@ core_pattern <|> some_pattern <|> var_pattern -var_pattern :: Parser (Pattern ASTInfo) +var_pattern :: Parser (Pascal ASTInfo) var_pattern = - ctor IsVar <*> name + ranged do + pure IsVar <*> name -some_pattern :: Parser (Pattern ASTInfo) +some_pattern :: Parser (Pascal ASTInfo) some_pattern = do subtree "Some_pattern" do - ctor IsConstr - <*> do inside "constr" do ctor Name <*> token "Some" - <*> do Just <$> inside "arg" pattern + ranged do + pure IsConstr + <*> inside "constr" do + ranged do + pure Name <*> token "Some" -string_pattern :: Parser (Pattern ASTInfo) + <*> do Just <$> inside "arg" pattern + +string_pattern :: Parser (Pascal ASTInfo) string_pattern = - ctor IsConstant <*> do - ctor String <*> token "String" + ranged do + pure IsConstant <*> do + ranged do + pure String <*> token "String" -nat_pattern :: Parser (Pattern ASTInfo) +nat_pattern :: Parser (Pascal ASTInfo) nat_pattern = - ctor IsConstant <*> do - ctor Nat <*> token "Nat" + ranged do + pure IsConstant <*> do + ranged do + pure Nat <*> token "Nat" -int_pattern :: Parser (Pattern ASTInfo) +int_pattern :: Parser (Pascal ASTInfo) int_pattern = - ctor IsConstant <*> do - ctor Int <*> token "Int" + ranged do + pure IsConstant <*> do + ranged do + pure Int <*> token "Int" -constr_pattern :: Parser (Pattern ASTInfo) +constr_pattern :: Parser (Pascal ASTInfo) constr_pattern = do subtree "user_constr_pattern" do - ctor IsConstr - <*> inside "constr:constr" capitalName - <*> optional do - inside "arguments" tuple_pattern + ranged do + pure IsConstr + <*> inside "constr:constr" capitalName + <*> optional do + inside "arguments" tuple_pattern <|> do - ctor IsConstr - <*> do ctor Name <*> do true <|> false <|> none <|> unit - <*> pure Nothing + ranged do + pure IsConstr + <*> ranged do + pure Name <*> do + true <|> false <|> none <|> unit + <*> pure Nothing -tuple_pattern :: Parser (Pattern ASTInfo) +tuple_pattern :: Parser (Pascal ASTInfo) tuple_pattern = do subtree "tuple_pattern" do - ctor IsTuple <*> many do - inside "element" pattern + ranged do + pure IsTuple <*> many do + inside "element" pattern -list_pattern :: Parser (Pattern ASTInfo) +list_pattern :: Parser (Pascal ASTInfo) list_pattern = do subtree "list_pattern" do - ctor IsList <*> many do - inside "element" pattern + ranged do + pure IsList <*> many do + inside "element" pattern -nullary_ctor :: Parser (Expr ASTInfo) +nullary_ctor :: Parser (Pascal ASTInfo) nullary_ctor = do - ctor Ident <*> do - ctor QualifiedName - <*> do ctor Name <*> do true <|> false <|> none <|> unit - <*> pure [] + ranged do + pure Ident <*> do + ranged do + pure QualifiedName + <*> ranged do + pure Name <*> do + true <|> false <|> none <|> unit + <*> pure [] true = token "True" false = token "False" none = token "None" unit = token "Unit" -nat_literal :: Parser (Expr ASTInfo) +nat_literal :: Parser (Pascal ASTInfo) nat_literal = do - ctor Constant <*> do - ctor Nat <*> token "Nat" + ranged do + pure Constant <*> do + ranged do + pure Nat <*> token "Nat" -bytes_literal :: Parser (Expr ASTInfo) +bytes_literal :: Parser (Pascal ASTInfo) bytes_literal = do - ctor Constant <*> do - ctor Bytes <*> token "Bytes" + ranged do + pure Constant <*> do + ranged do + pure Bytes <*> token "Bytes" -constr_call :: Parser (Expr ASTInfo) +constr_call :: Parser (Pascal 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 do inside "argument" expr + ranged do + pure Apply + <*> ranged do + pure Ident <*> inside "constr" qname' + <*> inside "arguments:arguments" do + many 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 do inside "argument" expr + ranged do + pure Apply + <*> inside "constr:constr" do + ranged do + pure Ident <*> do + ranged do + pure QualifiedName + <*> capitalName + <*> pure [] + <*> inside "arguments:arguments" do + many do + inside "argument" expr -indexing :: Parser (Expr ASTInfo) +indexing :: Parser (Pascal ASTInfo) indexing = do subtree "map_lookup" do - ctor Indexing - <*> inside "container:path" do - qname <|> projection - <*> inside "index" expr + ranged do + pure Indexing + <*> inside "container:path" do + qname <|> projection + <*> inside "index" expr -map_remove :: Parser (Expr ASTInfo) +map_remove :: Parser (Pascal ASTInfo) map_remove = do subtree "map_remove" do - ctor MapRemove - <*> inside "key" expr - <*> inside "container" do - inside ":path" do - qname <|> projection + ranged do + pure MapRemove + <*> inside "key" expr + <*> inside "container" do + inside ":path" do + qname <|> projection -big_map_expr :: Parser (Expr ASTInfo) +big_map_expr :: Parser (Pascal ASTInfo) big_map_expr = do subtree "big_map_injection" do - ctor BigMap <*> many do - inside "binding" do - map_binding + ranged do + pure BigMap <*> many do + inside "binding" do + map_binding -map_expr :: Parser (Expr ASTInfo) +map_expr :: Parser (Pascal ASTInfo) map_expr = do subtree "map_injection" do - ctor Map <*> many do - inside "binding" do - map_binding + ranged do + pure Map <*> many do + inside "binding" do + map_binding -map_binding :: Parser (MapBinding ASTInfo) +map_binding :: Parser (Pascal ASTInfo) map_binding = do subtree "binding" do - ctor MapBinding - <*> inside "key" expr - <*> inside "value" expr + ranged do + pure MapBinding + <*> inside "key" expr + <*> inside "value" expr -moduleQualified :: Parser (Expr ASTInfo) +moduleQualified :: Parser (Pascal ASTInfo) moduleQualified = do subtree "module_field" do - ctor Ident <*> do - ctor QualifiedName - <*> inside "module" capitalName - <*> do pure <$> do ctor At <*> inside "method" do name <|> name' + ranged do + pure Ident <*> do + ranged do + pure QualifiedName + <*> inside "module" capitalName + <*> do pure <$> ranged do + pure At <*> inside "method" do name <|> name' -tuple_expr :: Parser (Expr ASTInfo) +tuple_expr :: Parser (Pascal ASTInfo) tuple_expr = do subtree "tuple_expr" do - ctor Tuple <*> many do - inside "element" expr - -attributes :: Parser (Expr ASTInfo) -attributes = do - subtree "attr_decl" do - ctor Attrs <*> many do - inside "attribute" do - token "String" - -string_literal :: Parser (Expr ASTInfo) -string_literal = do - ctor Constant <*> do - ctor String <*> - token "String" - -has_type :: Parser (Expr ASTInfo) -has_type = do - subtree "annot_expr" do - ctor Annot - <*> inside "subject" expr - <*> inside "type" type_ - -list_expr :: Parser (Expr ASTInfo) -list_expr = do - subtree "list_expr" do - ctor List <*> many do + ranged do + pure Tuple <*> many do inside "element" expr -qname :: Parser (QualifiedName ASTInfo) +attributes :: Parser (Pascal ASTInfo) +attributes = do + subtree "attr_decl" do + ranged do + pure Attrs <*> many do + inside "attribute" do + token "String" + +string_literal :: Parser (Pascal ASTInfo) +string_literal = do + ranged do + pure Constant <*> do + ranged do + pure String <*> do + token "String" + +has_type :: Parser (Pascal ASTInfo) +has_type = do + subtree "annot_expr" do + ranged do + pure Annot + <*> inside "subject" expr + <*> inside "type" type_ + +list_expr :: Parser (Pascal ASTInfo) +list_expr = do + subtree "list_expr" do + ranged do + pure List <*> many do + inside "element" expr + +qname :: Parser (Pascal ASTInfo) qname = do - ctor QualifiedName - <*> name - <*> pure [] + ranged do + pure QualifiedName + <*> name + <*> pure [] -qname' :: Parser (QualifiedName ASTInfo) +qname' :: Parser (Pascal ASTInfo) qname' = do - ctor QualifiedName - <*> name' - <*> pure [] + ranged do + pure QualifiedName + <*> name' + <*> pure [] -assign :: Parser (Expr ASTInfo) +assign :: Parser (Pascal ASTInfo) assign = do subtree "assignment" do - ctor Assign - <*> inside "LHS" lhs - <*> inside "RHS" expr + ranged do + pure Assign + <*> inside "LHS" lhs + <*> inside "RHS" expr -lhs :: Parser (LHS ASTInfo) +lhs :: Parser (Pascal ASTInfo) lhs = - do ctor LHS - <*> inside "container:path" do - qname <|> projection - <*> pure Nothing + ranged do + pure LHS + <*> inside "container:path" do + qname <|> projection + <*> pure Nothing <|> - do ctor LHS - <*> subtree "path" do - qname <|> projection - <*> pure Nothing + ranged do + pure 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 + subtree "map_lookup" do + ranged do + pure LHS + <*> inside "container:path" do + qname <|> projection + <*> inside "index" do + Just <$> expr -tez_literal :: Parser (Expr ASTInfo) +tez_literal :: Parser (Pascal ASTInfo) tez_literal = do - ctor Constant <*> do - ctor Tez <*> token "Tez" + ranged do + pure Constant <*> do + ranged do + pure Tez <*> token "Tez" -if_expr :: Parser (Expr ASTInfo) +if_expr :: Parser (Pascal ASTInfo) if_expr = do subtree "conditional" do - ctor If - <*> inside "selector" expr - <*> inside "then:if_clause" expr - <*> inside "else:if_clause" expr + ranged do + pure 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 + ranged do + pure If + <*> inside "selector" expr + <*> inside "then" expr + <*> inside "else" expr -method_call :: Parser (Expr ASTInfo) +method_call :: Parser (Pascal ASTInfo) method_call = do subtree "projection_call" do - ctor apply' - <*> inside "f" projection - <*> optional do inside "arguments" arguments + ranged do + pure apply' + <*> getInfo + <*> inside "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 + apply' i f (Just xs) = Apply (mk i $ Ident f) xs + apply' i f _ = Ident f -projection :: Parser (QualifiedName ASTInfo) +projection :: Parser (Pascal ASTInfo) projection = do subtree "data_projection" do - ctor QualifiedName - <*> inside "struct" name - <*> many selection + ranged do + pure QualifiedName + <*> inside "struct" name + <*> many selection -selection :: Parser (Path ASTInfo) +selection :: Parser (Pascal ASTInfo) selection = do inside "index:selection" - $ do ctor At <*> name - <|> do ctor Ix <*> token "Int" + $ ranged do pure At <*> name + <|> ranged do pure Ix <*> token "Int" <|> inside "index" do - ctor Ix <*> token "Int" + ranged do pure Ix <*> token "Int" -par_call :: Parser (Expr ASTInfo) +par_call :: Parser (Pascal ASTInfo) par_call = do subtree "par_call" do - ctor apply' + pure apply' + <*> getInfo <*> inside "f" expr <*> optional do inside "arguments" arguments where - apply' r f (Just xs) = Apply r f xs - apply' _ f _ = f + apply' + :: ASTInfo + -> Pascal ASTInfo + -> Maybe [Pascal ASTInfo] + -> Pascal ASTInfo + apply' i f (Just xs) = mk i $ Apply f xs + apply' i f _ = f -int_literal :: Parser (Expr ASTInfo) +int_literal :: Parser (Pascal ASTInfo) int_literal = do - ctor Constant - <*> do ctor Int <*> token "Int" + ranged do + pure Constant + <*> ranged do + pure Int <*> token "Int" -record_expr :: Parser (Expr ASTInfo) +record_expr :: Parser (Pascal ASTInfo) record_expr = do subtree "record_expr" do - ctor Record <*> many do - inside "assignment:field_assignment" do - ctor Assignment - <*> inside "name" name - <*> inside "_rhs" expr + ranged do + pure Record <*> many do + inside "assignment:field_assignment" do + ranged do + pure Assignment + <*> inside "name" name + <*> inside "_rhs" expr -fun_call :: Parser (Expr ASTInfo) +fun_call :: Parser (Pascal ASTInfo) fun_call = do subtree "fun_call" do - ctor Apply - <*> do ctor Ident <*> inside "f" function_id - <*> inside "arguments" arguments + ranged do + pure Apply + <*> ranged do pure Ident <*> inside "f" function_id + <*> inside "arguments" arguments arguments = subtree "arguments" do many do inside "argument" expr -function_id :: Parser (QualifiedName ASTInfo) +function_id :: Parser (Pascal ASTInfo) function_id = select [ qname , do subtree "module_field" do - ctor QualifiedName - <*> inside "module" capitalName - <*> do pure <$> do ctor At <*> inside "method" do name <|> name' + ranged do + pure QualifiedName + <*> inside "module" capitalName + <*> do pure <$> ranged do + pure At <*> inside "method" do name <|> name' ] -opCall :: Parser (Expr ASTInfo) +opCall :: Parser (Pascal ASTInfo) opCall = do subtree "op_expr" $ do inside "the" expr - <|> do ctor BinOp - <*> inside "arg1" expr - <*> inside "op" anything - <*> inside "arg2" expr - <|> do ctor UnOp - <*> inside "negate" anything - <*> inside "arg" expr + <|> ranged do + pure BinOp + <*> inside "arg1" expr + <*> inside "op" anything + <*> inside "arg2" expr + <|> ranged do + pure UnOp + <*> inside "negate" anything + <*> inside "arg" expr letExpr = do subtree "let_expr" do - ctor let' + pure let' + <*> getInfo <*> optional do inside "locals:block" do many do inside "statement" do declaration <|> statement <*> inside "body"expr - where let' r decls body = case decls of - Just them -> Let r them body + Just them -> mk r $ Let them body Nothing -> body -statement :: Parser (Declaration ASTInfo) -statement = ctor Action <*> expr +statement :: Parser (Pascal ASTInfo) +statement = ranged do pure Action <*> expr -paramDecl :: Parser (VarDecl ASTInfo) +paramDecl :: Parser (Pascal ASTInfo) paramDecl = do subtree "param_decl" do - ctor Decl - <*> inside "access" do - ctor access' <*> anything - <*> inside "name" name - <*> inside "type" type_ + ranged do + pure Decl + <*> inside "access" do + ranged do + pure access' <*> anything + <*> inside "name" name + <*> inside "type" type_ where - access' r "var" = Mutable r - access' r "const" = Immutable r + access' "var" = Mutable + access' "const" = Immutable newtype_ = select [ record_type @@ -630,70 +748,78 @@ newtype_ = select sum_type = do subtree "sum_type" do - ctor TSum <*> many do - inside "variant" variant + ranged do + pure TSum <*> many do + inside "variant" variant variant = do subtree "variant" do - ctor Variant - <*> inside "constructor:constr" capitalName - <*> optional do inside "arguments" type_ + ranged do + pure Variant + <*> inside "constructor:constr" capitalName + <*> optional do inside "arguments" type_ record_type = do subtree "record_type" do - ctor TRecord <*> many do - inside "field" do - field_decl + ranged do + pure TRecord <*> many do + inside "field" do + field_decl field_decl = do subtree "field_decl" do - ctor TField - <*> inside "fieldName" name - <*> inside "fieldType" newtype_ + ranged do + pure TField + <*> inside "fieldName" name + <*> inside "fieldType" newtype_ -type_ :: Parser (Type ASTInfo) +type_ :: Parser (Pascal ASTInfo) type_ = fun_type where - fun_type :: Parser (Type ASTInfo) + fun_type :: Parser (Pascal ASTInfo) fun_type = do inside ":fun_type" do - ctor tarrow + pure tarrow + <*> getInfo <*> inside "domain" cartesian <*> optional do inside "codomain" fun_type where - tarrow info domain codomain = + tarrow i domain codomain = case codomain of - Just co -> TArrow info domain co + Just co -> mk i $ TArrow domain co Nothing -> domain cartesian = do inside ":cartesian" do - ctor TProduct <*> some do - inside "element" do - core_type + ranged do + pure TProduct <*> some do + inside "element" do + core_type core_type = do select - [ ctor TVar <*> name + [ ranged do pure TVar <*> name , subtree "invokeBinary" do - ctor TApply - <*> inside "typeConstr" name' - <*> inside "arguments" typeTuple + ranged do + pure TApply + <*> inside "typeConstr" name' + <*> inside "arguments" typeTuple , subtree "invokeUnary" do - ctor TApply - <*> inside "typeConstr" name' - <*> do pure <$> inside "arguments" type_ + ranged do + pure TApply + <*> inside "typeConstr" name' + <*> do pure <$> inside "arguments" type_ , subtree "type_expr" newtype_ ] -name' :: Parser (Name ASTInfo) +name' :: Parser (Pascal ASTInfo) name' = do - ctor Name <*> anything + ranged do pure Name <*> anything -typeTuple :: Parser [Type ASTInfo] +typeTuple :: Parser [Pascal ASTInfo] typeTuple = do subtree "type_tuple" do many do inside "element" type_ diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index ec151e636..2ed4d2563 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -11,16 +11,18 @@ module AST.Scope where import Control.Lens hiding (Const, List) import Control.Monad.State +import Data.Maybe import Data.Text (Text) import Data.Traversable import Data.Foldable import Parser import Range +import Update import AST.Types - -class UpdatableScopes a where - updateScopes :: HasRange r => (r -> ScopeM s) -> a r -> ScopeM (a s) +import Tree +import HasComments +import Pretty type ScopeM = State [Env] @@ -30,767 +32,298 @@ newtype Env = Env deriving newtype (Semigroup, Monoid) data ScopedDecl = ScopedDecl - { _sdName :: Maybe Text + { _sdName :: Maybe (Pascal ()) , _sdOrigin :: Maybe Range , _sdBody :: Maybe Range - , _sdType :: Maybe (Either (Type ()) Kind) + , _sdType :: Maybe (Either (Pascal ()) Kind) } data Kind = Star -block :: ScopeM a -> ScopeM a -block action = do - modify \(top : rest) -> top : top : rest -- inheriting outer scope - res <- action - modify tail -- dropping current frame - return res +instance HasMethods ScopeM where + data Methods ScopeM = MethodsScopeM + { enter_ :: ScopeM () + , leave_ :: ScopeM () + , define_ :: ScopedDecl -> ScopeM () + } -define :: ScopedDecl -> ScopeM () -define sd = do - modify \(Env top : rest) -> Env (sd : top) : rest + method = MethodsScopeM + { enter_ = modify \(a : b) -> a : a : b + , leave_ = modify tail + , define_ = \d -> modify \(Env a : b) -> Env (d : a) : b + } + +enter = enter_ method +leave = leave_ method +define = define_ method + +defType :: HasRange a => Pascal a -> Kind -> Pascal a -> ScopeM () +defType name kind body = do + define $ ScopedDecl + (Just (void name)) + (getRange <$> infoOf name) + (getRange <$> infoOf body) + (Just (Right kind)) def - :: ( HasRange i - , Foldable g - , Stubbed (g i) - ) - => Name i - -> g i - -> Type j + :: HasRange a + => Pascal a + -> Maybe (Pascal a) + -> Maybe (Pascal a) -> ScopeM () -def n b ty = +def name ty body = do define $ ScopedDecl - (n^?raw) - (n^?folded.location) - (b^?treeRange) - (Just $ Left $ void ty) + (Just (void name)) + (getRange <$> infoOf name) + (getRange <$> do infoOf =<< body) + ((Left . void) <$> ty) -defP - :: ( HasRange i - , Foldable g - , Stubbed (g i) - ) - => Name i - -> g i - -> Maybe (Type j) - -> ScopeM () -defP n b mty = - define $ ScopedDecl - (n^?raw) - (n^?folded.location) - (b^?treeRange) - (fmap (Left . void) mty) +instance UpdateOver ScopeM Contract (Pascal a) -defParam - :: ( HasRange i - ) - => Name i - -> Type j - -> ScopeM () -defParam n ty = - define $ ScopedDecl - (n^?raw) - (n^?folded.location) - Nothing - (Just $ Left $ void ty) +-- data Contract it +-- = Contract [it] +-- deriving (Show) via PP (Contract it) +-- deriving stock (Functor, Foldable, Traversable) -defI - :: ( HasRange i - ) - => Name i - -> ScopeM () -defI n = - define $ ScopedDecl - (n^?raw) - (n^?folded.location) - Nothing - Nothing +instance HasRange a => UpdateOver ScopeM Declaration (Pascal a) where + before = \case + TypeDecl ty body -> defType ty Star body + _ -> skip -defE - :: ( HasRange i - , Foldable f - , Stubbed (f i) - ) - => Name i - -> f i - -> ScopeM () -defE n b = - define $ ScopedDecl - (n^?raw) - (n^?folded.location) - (b^?treeRange) - Nothing - -defType - :: ( Foldable g - , HasRange i - , Stubbed (g i) - ) - => Name i - -> g i - -> Kind - -> ScopeM () -defType n b ki = - define $ ScopedDecl - (n^?raw) - (n^?folded.location) - (b^?treeRange) - (Just (Right ki)) - -treeRange - :: ( Foldable f - , HasRange a - , Stubbed (f a) - ) - => Fold (f a) Range -treeRange = folded.location - -instance UpdatableScopes Contract where - updateScopes update = \case - Contract i ds -> do - block do - Contract - <$> update i - <*> for ds (updateScopes update) - - WrongContract e -> do - return $ WrongContract e - - --- data Contract info --- = Contract info [Declaration info] --- | WrongContract Error - -instance UpdatableScopes Declaration where - updateScopes update = \case - ValueDecl i bind -> do - ValueDecl - <$> update i - <*> updateScopes update bind - - TypeDecl i n ty -> do - defType n ty Star - - TypeDecl - <$> update i - <*> updateScopes update n - <*> updateScopes update ty - - Action i expr -> do - Action - <$> update i - <*> updateScopes update expr - - Include i s -> do - Include - <$> update i - <*> pure s - - WrongDecl e -> do - return $ WrongDecl e - --- data Declaration info --- = ValueDecl info (Binding info) --- | TypeDecl info (Name info) (Type info) --- | Action info (Expr info) --- | Include info Text --- | WrongDecl Error - -instance UpdatableScopes Binding where - updateScopes update = \case - Irrefutable i p e -> do - res <- Irrefutable - <$> update i - <*> updateScopes update p - <*> updateScopes update e - - for_ (p^..patternNames) \name -> do - defE name e - - return res - - Function i recur n params ty body -> do - let - returns = telescope ((void) <$> params) - defineHere = def n body (returns (void ty)) +-- data Declaration it +-- = ValueDecl it -- Binding +-- | TypeDecl it it -- Name Type +-- | Action it -- Expr +-- | Include Text +-- deriving (Show) via PP (Declaration it) +-- deriving stock (Functor, Foldable, Traversable) +instance HasRange a => UpdateOver ScopeM Binding (Pascal a) where + before = \case + Function recur name args ty body -> do when recur do - defineHere + def name (Just ty) (Just body) + enter - res <- block do - Function - <$> update i - <*> pure recur - <*> updateScopes update n - <*> traverse (updateScopes update) params - <*> updateScopes update ty - <*> updateScopes update body + _ -> enter + after = \case + Irrefutable name body -> do leave; def name Nothing (Just body) + Var name ty body -> do leave; def name (Just ty) (Just body) + Const name ty body -> do leave; def name (Just ty) (Just body) + Function recur name args ty body -> do + leave unless recur do - defineHere - - return res - - Var i n ty e -> do - res <- Var - <$> update i - <*> updateScopes update n - <*> updateScopes update ty - <*> updateScopes update e - - def n e ty - - return res - - Const i n ty e -> do - res <- Const - <$> update i - <*> updateScopes update n - <*> updateScopes update ty - <*> updateScopes update e - - def n e ty - - return res - - WrongBinding e -> do - return $ WrongBinding e - -telescope :: [VarDecl i] -> Type () -> Type () -telescope = flip $ foldr \case - Decl _ _ _ ty -> TArrow () (void ty) - WrongVarDecl e -> TArrow () (WrongType e) - --- data Binding info --- = Irrefutable info (Pattern info) (Expr info) --- | Function info Bool (Name info) [VarDecl info] (Type info) (Expr info) --- | Var info (Name info) (Type info) (Expr info) --- | Const info (Name info) (Type info) (Expr info) --- | WrongBinding Error - -instance UpdatableScopes VarDecl where - updateScopes update = \case - Decl i mut n ty -> do - res <- Decl - <$> update i - <*> updateScopes update mut - <*> updateScopes update n - <*> updateScopes update ty - - defParam n ty - - return res - - WrongVarDecl e -> do - return $ WrongVarDecl e - --- data VarDecl info --- = Decl info (Mutable info) (Name info) (Type info) --- | WrongVarDecl Error - -instance UpdatableScopes Mutable where - updateScopes update = \case - Mutable i -> Mutable <$> update i - Immutable i -> Immutable <$> update i - WrongMutable e -> return $ WrongMutable e - --- data Mutable info --- = Mutable info --- | Immutable info --- | WrongMutable Error - -instance UpdatableScopes Type where - updateScopes update = \case - TArrow i cod dom -> do - TArrow - <$> update i - <*> updateScopes update cod - <*> updateScopes update dom - - TRecord i fs -> do - TRecord - <$> update i - <*> traverse (updateScopes update) fs - - TVar i n -> do - TVar - <$> update i - <*> updateScopes update n - - TSum i vs -> do - TSum - <$> update i - <*> traverse (updateScopes update) vs - - TProduct i es -> do - TProduct - <$> update i - <*> traverse (updateScopes update) es - - TApply i f xs -> do - TApply - <$> update i - <*> updateScopes update f - <*> traverse (updateScopes update) xs - - WrongType e -> do - return $ WrongType e - --- data Type info --- = TArrow info (Type info) (Type info) --- | TRecord info [TField info] --- | TVar info (Name info) --- | TSum info [Variant info] --- | TProduct info [Type info] --- | TApply info (Name info) [Type info] --- | WrongType Error - -instance UpdatableScopes Variant where - updateScopes update = \case - Variant i n mty -> do - res <- Variant - <$> update i - <*> updateScopes update n - <*> traverse (updateScopes update) mty - - defParam n $ case mty of - Just it -> TArrow () (void it) (TVar () (Name () "unknown")) - Nothing -> TVar () (Name () "unknown") - - return res - - WrongVariant e -> do - return $ WrongVariant e - --- data Variant info --- = Variant info (Name info) (Maybe (Type info)) --- | WrongVariant Error - -instance UpdatableScopes TField where - updateScopes update = \case - TField i a b -> do - TField - <$> update i - <*> updateScopes update a - <*> updateScopes update b - - WrongTField e -> do - return $ WrongTField e - --- data TField info --- = TField info (Name info) (Type info) --- | WrongTField Error - -instance UpdatableScopes Expr where - updateScopes update = \case - Let i ds b -> do - s <- update i - block do - Let s - <$> traverse (updateScopes update) ds - <*> updateScopes update b - - Apply i f xs -> - Apply - <$> update i - <*> updateScopes update f - <*> traverse (updateScopes update) xs - - Constant i c -> - Constant - <$> update i - <*> updateScopes update c - - Ident i qn -> do - Ident - <$> update i - <*> updateScopes update qn - - BinOp i l op r -> do - BinOp - <$> update i - <*> updateScopes update l - <*> pure op - <*> updateScopes update r - - UnOp i op r -> do - UnOp - <$> update i - <*> pure op - <*> updateScopes update r - - Record i fs -> do - Record - <$> update i - <*> traverse (updateScopes update) fs - - If i a b c -> do - If - <$> update i - <*> updateScopes update a - <*> updateScopes update b - <*> updateScopes update c - - Assign i l r -> do - Assign - <$> update i - <*> updateScopes update l - <*> updateScopes update r - - List i ls -> do - List - <$> update i - <*> traverse (updateScopes update) ls - - Set i ls -> do - Set - <$> update i - <*> traverse (updateScopes update) ls - - Tuple i ls -> do - Tuple - <$> update i - <*> traverse (updateScopes update) ls - - Annot i e ty -> do - Annot - <$> update i - <*> updateScopes update e - <*> updateScopes update ty - - Attrs i az -> do - Attrs - <$> update i - <*> pure az - - BigMap i ms -> do - BigMap - <$> update i - <*> traverse (updateScopes update) ms - - Map i ms -> do - Map - <$> update i - <*> traverse (updateScopes update) ms - - MapRemove i e qn -> do - MapRemove - <$> update i - <*> updateScopes update e - <*> updateScopes update qn - - SetRemove i e qn -> do - SetRemove - <$> update i - <*> updateScopes update e - <*> updateScopes update qn - - Indexing i q e -> do - Indexing - <$> update i - <*> updateScopes update q - <*> updateScopes update e - - Case i e az -> do - Case - <$> update i - <*> updateScopes update e - <*> traverse (updateScopes update) az - - Skip i -> Skip <$> update i - - ForLoop i n a b c -> do - block do - defI n - ForLoop - <$> update i - <*> updateScopes update n - <*> updateScopes update a - <*> updateScopes update b - <*> updateScopes update c - - WhileLoop i a b -> do - WhileLoop - <$> update i - <*> updateScopes update a - <*> updateScopes update b - - Seq i ds -> do - block do - Seq - <$> update i - <*> traverse (updateScopes update) ds - - Lambda i ps ty b -> do - block do - Lambda - <$> update i - <*> traverse (updateScopes update) ps - <*> updateScopes update ty - <*> updateScopes update b - - ForBox i a mb t e f -> do - block do - defI a - ForBox - <$> update i - <*> updateScopes update a - <*> traverse (updateScopes update) mb - <*> pure t - <*> updateScopes update e - <*> updateScopes update f - - MapPatch i q bs -> do - MapPatch - <$> update i - <*> updateScopes update q - <*> traverse (updateScopes update) bs - - SetPatch i q bs -> do - SetPatch - <$> update i - <*> updateScopes update q - <*> traverse (updateScopes update) bs - - RecordUpd i q fs -> do - RecordUpd - <$> update i - <*> updateScopes update q - <*> traverse (updateScopes update) fs - - WrongExpr e -> do - return $ WrongExpr e - --- data Expr info --- = Let info [Declaration info] (Expr info) --- | Apply info (Expr info) [Expr info] --- | Constant info (Constant info) --- | Ident info (QualifiedName info) --- | BinOp info (Expr info) Text (Expr info) --- | UnOp info Text (Expr info) --- | Record info [Assignment 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] --- | BigMap info [MapBinding 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 - -instance UpdatableScopes Alt where - updateScopes update = \case - Alt i p e -> do - block do - s <- update i - p' <- updateScopes update p - for_ (p^..patternNames) \name -> do - defI name - - Alt s p' - <$> updateScopes update e - - WrongAlt e -> do - return $ WrongAlt e - --- data Alt info --- = Alt info (Pattern info) (Expr info) --- | WrongAlt Error - -instance UpdatableScopes LHS where - updateScopes update = \case - LHS i q me -> do - LHS - <$> update i - <*> updateScopes update q - <*> traverse (updateScopes update) me - - WrongLHS e -> do - return $ WrongLHS e - --- data LHS info --- = LHS info (QualifiedName info) (Maybe (Expr info)) --- | WrongLHS Error - -instance UpdatableScopes MapBinding where - updateScopes update = \case - MapBinding i e f -> do - MapBinding - <$> update i - <*> updateScopes update e - <*> updateScopes update f - - WrongMapBinding e -> do - return $ WrongMapBinding e - --- data MapBinding info --- = MapBinding info (Expr info) (Expr info) --- | WrongMapBinding Error - -instance UpdatableScopes Assignment where - updateScopes update = \case - Assignment i n e -> do - Assignment - <$> update i - <*> updateScopes update n - <*> updateScopes update e - - WrongAssignment e -> do - return $ WrongAssignment e - --- data Assignment info --- = Assignment info (Name info) (Expr info) --- | WrongAssignment Error - -instance UpdatableScopes FieldAssignment where - updateScopes update = \case - FieldAssignment i q e -> do - FieldAssignment - <$> update i - <*> updateScopes update q - <*> updateScopes update e - - WrongFieldAssignment e -> do - return $ WrongFieldAssignment e - --- data FieldAssignment info --- = FieldAssignment info (QualifiedName info) (Expr info) --- | WrongFieldAssignment Error - -instance UpdatableScopes Constant where - updateScopes update = \case - Int i t -> Int <$> update i <*> pure t - Nat i t -> Nat <$> update i <*> pure t - String i t -> String <$> update i <*> pure t - Float i t -> Float <$> update i <*> pure t - Bytes i t -> Bytes <$> update i <*> pure t - Tez i t -> Tez <$> update i <*> pure t - WrongConstant e -> return $ WrongConstant e - --- data Constant info --- = Int info Text --- | Nat info Text --- | String info Text --- | Float info Text --- | Bytes info Text --- | Tez info Text --- | WrongConstant Error - -patternNames :: Fold (Pattern i) (Name i) -patternNames act = go - where - go = \case - IsConstr i n p -> IsConstr i <$> act n <*> traverse go p - IsConstant i c -> pure $ IsConstant i c - IsVar i n -> IsVar i <$> act n - IsCons i h t -> IsCons i <$> go h <*> go t - IsWildcard i -> pure $ IsWildcard i - IsList i ps -> IsList i <$> traverse go ps - IsTuple i ps -> IsTuple i <$> traverse go ps - WrongPattern e -> pure $ WrongPattern e - -instance UpdatableScopes Pattern where - updateScopes update = \case - IsConstr i n mp -> do - IsConstr - <$> update i - <*> updateScopes update n - <*> traverse (updateScopes update) mp - - IsConstant i c -> do - IsConstant - <$> update i - <*> updateScopes update c - - IsVar i n -> do - IsVar - <$> update i - <*> updateScopes update n - - IsCons i h t -> - IsCons - <$> update i - <*> updateScopes update h - <*> updateScopes update t - - IsWildcard i -> IsWildcard <$> update i - - IsList i l -> - IsList - <$> update i - <*> traverse (updateScopes update) l - - IsTuple i l -> - IsTuple - <$> update i - <*> traverse (updateScopes update) l - - WrongPattern e -> do - return $ WrongPattern e - --- data 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 - -instance UpdatableScopes QualifiedName where - updateScopes update = \case - QualifiedName i n ps -> do - QualifiedName - <$> update i - <*> updateScopes update n - <*> traverse (updateScopes update) ps - - WrongQualifiedName e -> do - return $ WrongQualifiedName e - --- data QualifiedName info + def name (Just ty) (Just body) + +-- data Binding it +-- = Irrefutable it it -- (Pattern) (Expr) +-- | Function Bool it [it] it it -- (Name) [VarDecl] (Type) (Expr) +-- | Var it it it -- (Name) (Type) (Expr) +-- | Const it it it -- (Name) (Type) (Expr) +-- deriving (Show) via PP (Binding it) +-- deriving stock (Functor, Foldable, Traversable) + +instance HasRange a => UpdateOver ScopeM VarDecl (Pascal a) where + after (Decl _ name ty) = def name (Just ty) Nothing + +-- data VarDecl it +-- = Decl it it it -- (Mutable) (Name) (Type) +-- deriving (Show) via PP (VarDecl it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM Mutable (Pascal a) + +-- data Mutable it +-- = Mutable +-- | Immutable +-- deriving (Show) via PP (Mutable it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM Type (Pascal a) + +-- data Type it +-- = TArrow it it -- (Type) (Type) +-- | TRecord [it] -- [TField] +-- | TVar it -- (Name) +-- | TSum [it] -- [Variant] +-- | TProduct [it] -- [Type] +-- | TApply it [it] -- (Name) [Type] +-- deriving (Show) via PP (Type it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM Variant (Pascal a) + +-- data Variant it +-- = Variant it (Maybe it) -- (Name) (Maybe (Type)) +-- deriving (Show) via PP (Variant it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM TField (Pascal a) + +-- data TField it +-- = TField it it -- (Name) (Type) +-- deriving (Show) via PP (TField it) +-- deriving stock (Functor, Foldable, Traversable) + +instance HasRange a => UpdateOver ScopeM Expr (Pascal a) where + before = \case + Let {} -> enter + Lambda {} -> enter + ForLoop k _ _ _ -> do + enter + def k Nothing Nothing + + ForBox k mv _ _ _ -> do + enter + def k Nothing Nothing + maybe skip (\v -> def v Nothing Nothing) mv + + _ -> skip + + after = \case + Let {} -> leave + Lambda {} -> leave + ForLoop {} -> leave + ForBox {} -> leave + _ -> skip + +-- -- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls. +-- data Expr it +-- = Let [it] it -- [Declaration] (Expr) +-- | Apply it [it] -- (Expr) [Expr] +-- | Constant it -- (Constant) +-- | Ident it -- (QualifiedName) +-- | BinOp it Text it -- (Expr) Text (Expr) +-- | UnOp Text it -- (Expr) +-- | Record [it] -- [Assignment] +-- | If it it it -- (Expr) (Expr) (Expr) +-- | Assign it it -- (LHS) (Expr) +-- | List [it] -- [Expr] +-- | Set [it] -- [Expr] +-- | Tuple [it] -- [Expr] +-- | Annot it it -- (Expr) (Type) +-- | Attrs [Text] +-- | BigMap [it] -- [MapBinding] +-- | Map [it] -- [MapBinding] +-- | MapRemove it it -- (Expr) (QualifiedName) +-- | SetRemove it it -- (Expr) (QualifiedName) +-- | Indexing it it -- (QualifiedName) (Expr) +-- | Case it [it] -- (Expr) [Alt] +-- | Skip +-- | ForLoop it it it it -- (Name) (Expr) (Expr) (Expr) +-- | WhileLoop it it -- (Expr) (Expr) +-- | Seq [it] -- [Declaration] +-- | Lambda [it] it it -- [VarDecl] (Type) (Expr) +-- | ForBox it (Maybe it) Text it it -- (Name) (Maybe (Name)) Text (Expr) (Expr) +-- | MapPatch it [it] -- (QualifiedName) [MapBinding] +-- | SetPatch it [it] -- (QualifiedName) [Expr] +-- | RecordUpd it [it] -- (QualifiedName) [FieldAssignment] +-- deriving (Show) via PP (Expr it) +-- deriving stock (Functor, Foldable, Traversable) + +instance HasRange a => UpdateOver ScopeM Alt (Pascal a) where + before _ = enter + after _ = leave + +-- data Alt it +-- = Alt it it -- (Pattern) (Expr) +-- deriving (Show) via PP (Alt it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM LHS (Pascal a) + +-- data LHS it +-- = LHS it (Maybe it) -- (QualifiedName) (Maybe (Expr)) +-- deriving (Show) via PP (LHS it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM MapBinding (Pascal a) + +-- data MapBinding it +-- = MapBinding it it -- (Expr) (Expr) +-- deriving (Show) via PP (MapBinding it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM Assignment (Pascal a) + +-- data Assignment it +-- = Assignment it it -- (Name) (Expr) +-- deriving (Show) via PP (Assignment it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM FieldAssignment (Pascal a) + +-- data FieldAssignment it +-- = FieldAssignment it it -- (QualifiedName) (Expr) +-- deriving (Show) via PP (FieldAssignment it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM Constant (Pascal a) + +-- data Constant it +-- = Int Text +-- | Nat Text +-- | String Text +-- | Float Text +-- | Bytes Text +-- | Tez Text +-- deriving (Show) via PP (Constant it) +-- deriving stock (Functor, Foldable, Traversable) + +instance HasRange a => UpdateOver ScopeM Pattern (Pascal a) where + before = \case + IsVar n -> def n Nothing Nothing + _ -> skip + +-- data Pattern it +-- = IsConstr it (Maybe it) -- (Name) (Maybe (Pattern)) +-- | IsConstant it -- (Constant) +-- | IsVar it -- (Name) +-- | IsCons it it -- (Pattern) (Pattern) +-- | IsWildcard +-- | IsList [it] -- [Pattern] +-- | IsTuple [it] -- [Pattern] +-- deriving (Show) via PP (Pattern it) +-- deriving stock (Functor, Foldable, Traversable) + +instance UpdateOver ScopeM QualifiedName (Pascal a) + +-- data QualifiedName it -- = QualifiedName --- { qnInfo :: info --- , qnSource :: Name info --- , qnPath :: [Path info] +-- { qnSource :: it -- Name +-- , qnPath :: [it] -- [Path] -- } --- | WrongQualifiedName Error +-- deriving (Show) via PP (QualifiedName it) +-- deriving stock (Functor, Foldable, Traversable) -instance UpdatableScopes Path where - updateScopes update = \case - At i n -> At <$> update i <*> updateScopes update n - Ix i n -> Ix <$> update i <*> pure n - WrongPath e -> return $ WrongPath e +instance UpdateOver ScopeM Path (Pascal a) --- data Path info --- = At info (Name info) --- | Ix info Text --- | WrongPath Error +-- data Path it +-- = At it -- (Name) +-- | Ix Text +-- deriving (Show) via PP (Path it) +-- deriving stock (Functor, Foldable, Traversable) -instance UpdatableScopes Name where - updateScopes update = \case - Name i r -> Name <$> update i <*> pure r - WrongName e -> do - return $ WrongName e +instance UpdateOver ScopeM Name (Pascal a) --- data Name info = Name --- { info :: info --- , raw :: Text +-- data Name it = Name +-- { _raw :: Text -- } --- | WrongName Error +-- deriving (Show) via PP (Name it) +-- deriving stock (Functor, Foldable, Traversable) + +data Scope = Scope { unScope :: Text } + +instance HasComments Scope where + getComments = pure . ("(* " <>) . (<> " *)") . unScope + +runScopeM :: ScopeM a -> a +runScopeM action = evalState action [Env []] + +testUpdate :: Pascal ASTInfo -> ScopeM (Pascal Scope) +testUpdate = updateTree \_ -> do + Env topmost <- gets head + let names = catMaybes $ _sdName <$> topmost + let res = ppToText $ fsep $ map pp names + return $ Scope res \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index 159501541..16ddf5295 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/tools/lsp/squirrel/src/AST/Types.hs @@ -18,408 +18,311 @@ import Data.Void import Parser import ParseTree import Pretty +import Tree import TH import Debug.Trace -data Contract info - = Contract info [Declaration info] - | WrongContract Error - deriving (Show) via PP (Contract info) +data Contract it + = Contract [it] + deriving (Show) via PP (Contract it) deriving stock (Functor, Foldable, Traversable) -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) +data Declaration it + = ValueDecl it -- Binding + | TypeDecl it it -- Name Type + | Action it -- Expr + | Include Text + deriving (Show) via PP (Declaration it) deriving stock (Functor, Foldable, Traversable) -data Binding info - = Irrefutable info (Pattern info) (Expr info) - | Function info Bool (Name info) [VarDecl info] (Type info) (Expr info) - | Var info (Name info) (Type info) (Expr info) - | Const info (Name info) (Type info) (Expr info) - | WrongBinding Error - deriving (Show) via PP (Binding info) +data Binding it + = Irrefutable it it -- (Pattern) (Expr) + | Function Bool it [it] it it -- (Name) [VarDecl] (Type) (Expr) + | Var it it it -- (Name) (Type) (Expr) + | Const it it it -- (Name) (Type) (Expr) + deriving (Show) via PP (Binding it) deriving stock (Functor, Foldable, Traversable) -data VarDecl info - = Decl info (Mutable info) (Name info) (Type info) - | WrongVarDecl Error - deriving (Show) via PP (VarDecl info) +data VarDecl it + = Decl it it it -- (Mutable) (Name) (Type) + deriving (Show) via PP (VarDecl it) deriving stock (Functor, Foldable, Traversable) -data Mutable info - = Mutable info - | Immutable info - | WrongMutable Error - deriving (Show) via PP (Mutable info) +data Mutable it + = Mutable + | Immutable + deriving (Show) via PP (Mutable it) deriving stock (Functor, Foldable, Traversable) -data Type info - = TArrow info (Type info) (Type info) - | TRecord info [TField info] - | TVar info (Name info) - | TSum info [Variant info] - | TProduct info [Type info] - | TApply info (Name info) [Type info] - | WrongType Error - deriving (Show) via PP (Type info) +data Type it + = TArrow it it -- (Type) (Type) + | TRecord [it] -- [TField] + | TVar it -- (Name) + | TSum [it] -- [Variant] + | TProduct [it] -- [Type] + | TApply it [it] -- (Name) [Type] + deriving (Show) via PP (Type it) deriving stock (Functor, Foldable, Traversable) -data Variant info - = Variant info (Name info) (Maybe (Type info)) - | WrongVariant Error - deriving (Show) via PP (Variant info) +data Variant it + = Variant it (Maybe it) -- (Name) (Maybe (Type)) + deriving (Show) via PP (Variant it) deriving stock (Functor, Foldable, Traversable) -data TField info - = TField info (Name info) (Type info) - | WrongTField Error - deriving (Show) via PP (TField info) +data TField it + = TField it it -- (Name) (Type) + deriving (Show) via PP (TField it) deriving stock (Functor, Foldable, Traversable) -- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls. -data Expr info - = Let info [Declaration info] (Expr info) - | Apply info (Expr info) [Expr info] - | Constant info (Constant info) - | Ident info (QualifiedName info) - | BinOp info (Expr info) Text (Expr info) - | UnOp info Text (Expr info) - | Record info [Assignment 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] - | BigMap info [MapBinding 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) +data Expr it + = Let [it] it -- [Declaration] (Expr) + | Apply it [it] -- (Expr) [Expr] + | Constant it -- (Constant) + | Ident it -- (QualifiedName) + | BinOp it Text it -- (Expr) Text (Expr) + | UnOp Text it -- (Expr) + | Record [it] -- [Assignment] + | If it it it -- (Expr) (Expr) (Expr) + | Assign it it -- (LHS) (Expr) + | List [it] -- [Expr] + | Set [it] -- [Expr] + | Tuple [it] -- [Expr] + | Annot it it -- (Expr) (Type) + | Attrs [Text] + | BigMap [it] -- [MapBinding] + | Map [it] -- [MapBinding] + | MapRemove it it -- (Expr) (QualifiedName) + | SetRemove it it -- (Expr) (QualifiedName) + | Indexing it it -- (QualifiedName) (Expr) + | Case it [it] -- (Expr) [Alt] + | Skip + | ForLoop it it it it -- (Name) (Expr) (Expr) (Expr) + | WhileLoop it it -- (Expr) (Expr) + | Seq [it] -- [Declaration] + | Lambda [it] it it -- [VarDecl] (Type) (Expr) + | ForBox it (Maybe it) Text it it -- (Name) (Maybe (Name)) Text (Expr) (Expr) + | MapPatch it [it] -- (QualifiedName) [MapBinding] + | SetPatch it [it] -- (QualifiedName) [Expr] + | RecordUpd it [it] -- (QualifiedName) [FieldAssignment] + deriving (Show) via PP (Expr it) deriving stock (Functor, Foldable, Traversable) -data Alt info - = Alt info (Pattern info) (Expr info) - | WrongAlt Error - deriving (Show) via PP (Alt info) +data Alt it + = Alt it it -- (Pattern) (Expr) + deriving (Show) via PP (Alt it) deriving stock (Functor, Foldable, Traversable) -data LHS info - = LHS info (QualifiedName info) (Maybe (Expr info)) - | WrongLHS Error - deriving (Show) via PP (LHS info) +data LHS it + = LHS it (Maybe it) -- (QualifiedName) (Maybe (Expr)) + deriving (Show) via PP (LHS it) deriving stock (Functor, Foldable, Traversable) -data MapBinding info - = MapBinding info (Expr info) (Expr info) - | WrongMapBinding Error - deriving (Show) via PP (MapBinding info) +data MapBinding it + = MapBinding it it -- (Expr) (Expr) + deriving (Show) via PP (MapBinding it) deriving stock (Functor, Foldable, Traversable) -data Assignment info - = Assignment info (Name info) (Expr info) - | WrongAssignment Error - deriving (Show) via PP (Assignment info) +data Assignment it + = Assignment it it -- (Name) (Expr) + deriving (Show) via PP (Assignment it) deriving stock (Functor, Foldable, Traversable) -data FieldAssignment info - = FieldAssignment info (QualifiedName info) (Expr info) - | WrongFieldAssignment Error - deriving (Show) via PP (FieldAssignment info) +data FieldAssignment it + = FieldAssignment it it -- (QualifiedName) (Expr) + deriving (Show) via PP (FieldAssignment it) deriving stock (Functor, Foldable, Traversable) -data Constant info - = Int info Text - | Nat info Text - | String info Text - | Float info Text - | Bytes info Text - | Tez info Text - | WrongConstant Error - deriving (Show) via PP (Constant info) +data Constant it + = Int Text + | Nat Text + | String Text + | Float Text + | Bytes Text + | Tez Text + deriving (Show) via PP (Constant it) deriving stock (Functor, Foldable, Traversable) -data 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) +data Pattern it + = IsConstr it (Maybe it) -- (Name) (Maybe (Pattern)) + | IsConstant it -- (Constant) + | IsVar it -- (Name) + | IsCons it it -- (Pattern) (Pattern) + | IsWildcard + | IsList [it] -- [Pattern] + | IsTuple [it] -- [Pattern] + deriving (Show) via PP (Pattern it) deriving stock (Functor, Foldable, Traversable) -data QualifiedName info +data QualifiedName it = QualifiedName - { qnInfo :: info - , qnSource :: Name info - , qnPath :: [Path info] + { qnSource :: it -- Name + , qnPath :: [it] -- [Path] } - | WrongQualifiedName Error - deriving (Show) via PP (QualifiedName info) + deriving (Show) via PP (QualifiedName it) deriving stock (Functor, Foldable, Traversable) -data Path info - = At info (Name info) - | Ix info Text - | WrongPath Error - deriving (Show) via PP (Path info) +data Path it + = At it -- (Name) + | Ix Text + deriving (Show) via PP (Path it) deriving stock (Functor, Foldable, Traversable) -data Name info = Name - { _info :: info - , _raw :: Text +data Name it = Name + { _raw :: Text } - | WrongName Error - deriving (Show) via PP (Name info) + deriving (Show) via PP (Name it) deriving stock (Functor, Foldable, Traversable) -c :: HasComments i => i -> Doc -> Doc -c i d = - case getComments i of - [] -> d - cc -> block (map removeSlashN cc) $$ d - where - removeSlashN txt = - if "\n" `Text.isSuffixOf` txt - then Text.init txt - else txt - -instance HasComments i => Pretty (Contract i) where - pp = \case - Contract i decls -> c i $ +instance Pretty1 Contract where + pp1 = \case + Contract decls -> sparseBlock decls - WrongContract err -> - pp err +instance Pretty1 Declaration where + pp1 = \case + ValueDecl binding -> binding + TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty + Action e -> e + Include f -> "#include" <+> pp f -instance HasComments i => Pretty (Declaration i) where - pp = \case - ValueDecl i binding -> c i $ pp binding - TypeDecl i n ty -> c i $ "type" <+> pp n <+> "=" `indent` pp ty - Action i e -> c i $ pp e - Include i f -> c i $ "#include" <+> pp f - WrongDecl err -> pp err - -instance HasComments i => Pretty (Binding i) where - pp = \case - Irrefutable i pat expr -> error "irrefs in pascaligo?" - Function i isRec name params ty body -> - c i $ +instance Pretty1 Binding where + pp1 = \case + Irrefutable pat expr -> error "irrefs in pascaligo?" + Function isRec name params ty body -> + ( ( - ( - ( (if isRec then "recursive" else empty) - <+> "function" - <+> pp name - ) - `indent` tuple params + ( (if isRec then "recursive" else empty) + <+> "function" + <+> name ) - `indent` (":" <+> pp ty <+> "is") + `indent` tuple params ) - `indent` pp body - Var i name ty value -> c i $ "var" <+> pp name <+> ":" <+> pp ty <+> ":=" `indent` pp value - Const i name ty body -> c i $ "const" <+> pp name <+> ":" <+> pp ty <+> "=" `indent` pp body - WrongBinding err -> - pp err + `indent` (":" <+> ty <+> "is") + ) + `indent` body + Var name ty value -> "var" <+> name <+> ":" <+> ty <+> ":=" `indent` value + Const name ty body -> "const" <+> name <+> ":" <+> ty <+> "=" `indent` body -instance HasComments i => Pretty (VarDecl i) where - pp = \case - Decl i mutability name ty -> c i $ - pp mutability <+> pp name <+> ":" `indent` pp ty - WrongVarDecl err -> - pp err +instance Pretty1 VarDecl where + pp1 = \case + Decl mutability name ty -> mutability <+> name <+> ":" `indent` ty -instance HasComments i => Pretty (Mutable i) where - pp = \case - Mutable i -> c i $ "var" - Immutable i -> c i $ "const" - WrongMutable err -> pp err +instance Pretty1 Mutable where + pp1 = \case + Mutable -> "var" + Immutable -> "const" -instance HasComments i => Pretty (Type i) where - pp = \case - TArrow i dom codom -> c i $ parens (pp dom `indent` "->" <+> pp codom) - TRecord i fields -> c i $ "record [" `indent` block fields `above` "]" - TVar i name -> c i $ pp name - TSum i variants -> c i $ block variants - TProduct i elements -> c i $ train " *" elements - TApply i f xs -> c i $ pp f <> tuple xs - WrongType err -> pp err +instance Pretty1 Type where + pp1 = \case + TArrow dom codom -> parens (dom `indent` "->" <+> codom) + TRecord fields -> "record [" `indent` block fields `above` "]" + TVar name -> name + TSum variants -> block variants + TProduct elements -> train " *" elements + TApply f xs -> f <> tuple xs where - ppField (name, ty) = pp name <> ": " <> pp ty <> ";" + ppField (name, ty) = name <> ": " <> ty <> ";" -instance HasComments i => Pretty (Variant i) where - pp = \case - Variant i ctor (Just ty) -> c i $ "|" <+> pp ctor <+> "of" `indent` pp ty - Variant i ctor _ -> c i $ "|" <+> pp ctor - WrongVariant err -> pp err +instance Pretty1 Variant where + pp1 = \case + Variant ctor (Just ty) -> "|" <+> ctor <+> "of" `indent` ty + Variant ctor _ -> "|" <+> ctor --- My eyes. -instance HasComments i => Pretty (Expr i) where - pp = \case - Let i decls body -> c i $ "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` pp body - Apply i f xs -> c i $ pp f <+> tuple xs - Constant i constant -> c i $ pp constant - Ident i qname -> c i $ pp qname - BinOp i l o r -> c i $ parens (pp l <+> pp o <+> pp r) - UnOp i o r -> c i $ parens (pp o <+> pp r) - Record i az -> c i $ "record" <+> list az - If i b t e -> c i $ fsep ["if" `indent` pp b, "then" `indent` pp t, "else" `indent` pp e] - Assign i l r -> c i $ pp l <+> ":=" `indent` pp r - List i l -> c i $ "list" <+> list l - Set i l -> c i $ "set" <+> list l - Tuple i l -> c i $ tuple l - Annot i n t -> c i $ parens (pp n <+> ":" `indent` pp t) - Attrs i ts -> c i $ "attributes" <+> list ts - BigMap i bs -> c i $ "big_map" <+> list bs - Map i bs -> c i $ "map" <+> list bs - MapRemove i k m -> c i $ "remove" `indent` pp k `above` "from" <+> "map" `indent` pp m - SetRemove i k s -> c i $ "remove" `indent` pp k `above` "from" <+> "set" `indent` pp s - Indexing i a j -> c i $ pp a <> list [j] - Case i s az -> c i $ "case" <+> pp s <+> "of" `indent` block az - Skip i -> c i $ "skip" - ForLoop i j s f b -> c i $ "for" <+> pp j <+> ":=" <+> pp s <+> "to" <+> pp f `indent` pp b - ForBox i k mv t z b -> c i $ "for" <+> pp k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> pp z `indent` pp b - WhileLoop i f b -> c i $ "while" <+> pp f `indent` pp b - Seq i es -> c i $ "block {" `indent` sparseBlock es `above` "}" - Lambda i ps ty b -> c i $ (("function" `indent` tuple ps) `indent` (":" <+> pp ty)) `indent` pp b - MapPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "map" `indent` list bs - SetPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "set" `indent` list bs - RecordUpd i r up -> c i $ pp r `indent` "with" <+> "record" `indent` list up - WrongExpr err -> pp err +instance Pretty1 Expr where + pp1 = \case + Let decls body -> "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` body + Apply f xs -> f <+> tuple xs + Constant constant -> constant + Ident qname -> qname + BinOp l o r -> parens (l <+> pp o <+> r) + UnOp o r -> parens (pp o <+> r) + Record az -> "record" <+> list az + If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e] + Assign l r -> l <+> ":=" `indent` r + List l -> "list" <+> list l + 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 + Skip -> "skip" + ForLoop j s f b -> "for" <+> j <+> ":=" <+> s <+> "to" <+> f `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` sparseBlock es `above` "}" + Lambda ps ty b -> (("function" `indent` tuple ps) `indent` (":" <+> ty)) `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 -instance HasComments i => Pretty (Alt i) where - pp = \case - Alt i p b -> c i $ "|" <+> pp p <+> "->" `indent` pp b - WrongAlt err -> pp err +instance Pretty1 Alt where + pp1 = \case + Alt p b -> "|" <+> p <+> "->" `indent` b -instance HasComments i => Pretty (MapBinding i) where - pp = \case - MapBinding i k v -> c i $ pp k <+> "->" `indent` pp v - WrongMapBinding err -> pp err +instance Pretty1 MapBinding where + pp1 = \case + MapBinding k v -> k <+> "->" `indent` v -instance HasComments i => Pretty (Assignment i) where - pp = \case - Assignment i n e -> c i $ pp n <+> "=" `indent` pp e - WrongAssignment err -> pp err +instance Pretty1 Assignment where + pp1 = \case + Assignment n e -> n <+> "=" `indent` e -instance HasComments i => Pretty (FieldAssignment i) where - pp = \case - FieldAssignment i n e -> c i $ pp n <+> "=" `indent` pp e - WrongFieldAssignment err -> pp err +instance Pretty1 FieldAssignment where + pp1 = \case + FieldAssignment n e -> n <+> "=" `indent` e -instance HasComments i => Pretty (Constant i) where - pp = \case - Int i z -> c i $ pp z - Nat i z -> c i $ pp z - String i z -> c i $ pp z - Float i z -> c i $ pp z - Bytes i z -> c i $ pp z - Tez i z -> c i $ pp z - WrongConstant err -> pp err +instance Pretty1 Constant where + pp1 = \case + Int z -> pp z + Nat z -> pp z + String z -> pp z + Float z -> pp z + Bytes z -> pp z + Tez z -> pp z -instance HasComments i => Pretty (QualifiedName i) where - pp = \case - QualifiedName i src path -> c i $ pp src <> sepByDot path - WrongQualifiedName err -> pp err +instance Pretty1 QualifiedName where + pp1 = \case + QualifiedName src path -> src <> sepByDot path -instance HasComments i => Pretty (Pattern i) where - pp = \case - IsConstr i ctor arg -> c i $ pp ctor <+> maybe empty pp arg - IsConstant i z -> c i $ pp z - IsVar i name -> c i $ pp name - IsCons i h t -> c i $ pp h <+> ("#" <+> pp t) - IsWildcard i -> c i $ "_" - IsList i l -> c i $ list l - IsTuple i t -> c i $ tuple t - WrongPattern err -> pp err +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) + IsWildcard -> "_" + IsList l -> list l + IsTuple t -> tuple t -instance HasComments i => Pretty (Name i) where - pp = \case - Name i raw -> c i $ pp raw - WrongName err -> pp err +instance Pretty1 Name where + pp1 = \case + Name raw -> pp raw -instance HasComments i => Pretty (Path i) where - pp = \case - At i n -> c i $ pp n - Ix i j -> c i $ pp j - WrongPath err -> pp err +instance Pretty1 Path where + pp1 = \case + At n -> n + Ix j -> pp j -instance HasComments i => Pretty (TField i) where - pp = \case - TField i n t -> c i $ pp n <> ":" `indent` pp t - WrongTField err -> pp err +instance Pretty1 TField where + pp1 = \case + TField n t -> n <> ":" `indent` t -instance HasComments i => Pretty (LHS i) where - pp = \case - LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi - WrongLHS err -> pp err +instance Pretty1 LHS where + pp1 = \case + LHS qn mi -> qn <> foldMap brackets mi -foldMap makePrisms - [ ''Name - , ''Path - , ''QualifiedName - , ''Pattern - , ''Constant - , ''FieldAssignment - , ''Assignment - , ''MapBinding - , ''LHS - , ''Alt - , ''Expr - , ''TField - , ''Variant - , ''Type - , ''Mutable - , ''VarDecl - , ''Binding - , ''Declaration - , ''Contract +type Pascal = Tree + [ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment + , MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding + , Declaration, Contract ] - -foldMap makeLenses - [ ''Name - ] - -instance Stubbed (Name info) where stubbing = _WrongName -instance Stubbed (Path info) where stubbing = _WrongPath -instance Stubbed (QualifiedName info) where stubbing = _WrongQualifiedName -instance Stubbed (Pattern info) where stubbing = _WrongPattern -instance Stubbed (Constant info) where stubbing = _WrongConstant -instance Stubbed (FieldAssignment info) where stubbing = _WrongFieldAssignment -instance Stubbed (Assignment info) where stubbing = _WrongAssignment -instance Stubbed (MapBinding info) where stubbing = _WrongMapBinding -instance Stubbed (LHS info) where stubbing = _WrongLHS -instance Stubbed (Alt info) where stubbing = _WrongAlt -instance Stubbed (Expr info) where stubbing = _WrongExpr -instance Stubbed (TField info) where stubbing = _WrongTField -instance Stubbed (Variant info) where stubbing = _WrongVariant -instance Stubbed (Type info) where stubbing = _WrongType -instance Stubbed (Mutable info) where stubbing = _WrongMutable -instance Stubbed (VarDecl info) where stubbing = _WrongVarDecl -instance Stubbed (Binding info) where stubbing = _WrongBinding -instance Stubbed (Declaration info) where stubbing = _WrongDecl -instance Stubbed (Contract info) where stubbing = _WrongContract diff --git a/tools/lsp/squirrel/src/Error.hs b/tools/lsp/squirrel/src/Error.hs new file mode 100644 index 000000000..488247126 --- /dev/null +++ b/tools/lsp/squirrel/src/Error.hs @@ -0,0 +1,20 @@ + +module Error where + +import Data.Text (Text) + +import Pretty +import Range + +-- | Parse error. +data Error + = Expected + { eMsg :: Text -- ^ Description of what was expected. + , eWhole :: Text -- ^ Offending text. + , eRange :: Range -- ^ Location of the error. + } + deriving (Show) via PP Error + +instance Pretty Error where + pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓" + diff --git a/tools/lsp/squirrel/src/HasComments.hs b/tools/lsp/squirrel/src/HasComments.hs new file mode 100644 index 000000000..cdea6989a --- /dev/null +++ b/tools/lsp/squirrel/src/HasComments.hs @@ -0,0 +1,23 @@ + +module HasComments where + +import qualified Data.Text as Text + +import Pretty + +class HasComments c where + getComments :: c -> [Text.Text] + +c :: HasComments i => i -> Doc -> Doc +c i d = + case getComments i of + [] -> d + cc -> block (map removeSlashN cc) $$ d + where + removeSlashN txt = + if "\n" `Text.isSuffixOf` txt + then Text.init txt + else txt + +instance HasComments () where + getComments () = [] \ No newline at end of file diff --git a/tools/lsp/squirrel/src/HasErrors.hs b/tools/lsp/squirrel/src/HasErrors.hs new file mode 100644 index 000000000..0277238ce --- /dev/null +++ b/tools/lsp/squirrel/src/HasErrors.hs @@ -0,0 +1,6 @@ +module HasErrors where + +import Error + +class HasErrors h where + errors :: h -> [Error] diff --git a/tools/lsp/squirrel/src/Lattice.hs b/tools/lsp/squirrel/src/Lattice.hs new file mode 100644 index 000000000..8ffc6536d --- /dev/null +++ b/tools/lsp/squirrel/src/Lattice.hs @@ -0,0 +1,11 @@ + +module Lattice where + +class Lattice l where + (?>) :: l -> l -> Bool + ( l -> Bool + + (?>) = flip () + + {-# minimal (?>) | ( pp msg <> pp r <> "▒" <> pp found <> "▓" - -- | Parser of tree-sitter-made tree. -- -- TODO: separate state. Polysemy? @@ -117,13 +107,13 @@ newtype Parser a = Parser -- | Generate error originating at current location. makeError :: Text -> Parser Error makeError msg = do - rng <- getRange + rng <- currentRange makeError' msg rng -- | Generate error originating at given location. makeError' :: Text -> Range -> Parser Error makeError' msg rng = do - rng <- getRange + rng <- currentRange src <- gets (pfGrove . fst) <&> \case [] -> "" (,) _ ParseTree { ptSource } : _ -> ptSource @@ -343,8 +333,8 @@ range parser = return (a, pfRange) -- | Get current range. -getRange :: Parser Range -getRange = snd <$> range (return ()) +currentRange :: Parser Range +currentRange = snd <$> range (return ()) -- | Remove all keys until given key is found; remove the latter as well. -- @@ -392,26 +382,7 @@ notFollowedBy parser = do die "notFollowedBy" stub :: Stubbed a => Error -> a -stub = (stubbing #) - --- | For types that have a default replacer with an `Error`. -class Stubbed a where - stubbing :: Prism' a Error - -instance Stubbed Text where - stubbing = prism (pack . show) Left - --- | This is bad, but I had to. --- --- TODO: Find a way to remove this instance. --- I probably need a wrapper around '[]'. --- -instance Stubbed [a] where - stubbing = prism (const []) Left - --- | `Nothing` would be bad default replacer. -instance Stubbed a => Stubbed (Maybe a) where - stubbing = _Just . stubbing +stub = stubbing -- | Universal accessor. -- @@ -447,15 +418,15 @@ data ASTInfo = ASTInfo , aiComments :: [Text] } -class HasComments c where - getComments :: c -> [Text] - instance HasComments ASTInfo where getComments = aiComments +instance HasRange ASTInfo where + getRange = aiRange + -- | Equip given constructor with info. -ctor :: (ASTInfo -> a) -> Parser a -ctor = (<$> (ASTInfo <$> getRange <*> grabComments)) +getInfo :: Parser ASTInfo +getInfo = ASTInfo <$> currentRange <*> grabComments grabComments :: Parser [Text] grabComments = do diff --git a/tools/lsp/squirrel/src/Pretty.hs b/tools/lsp/squirrel/src/Pretty.hs index e1347297b..4f74fd524 100644 --- a/tools/lsp/squirrel/src/Pretty.hs +++ b/tools/lsp/squirrel/src/Pretty.hs @@ -9,10 +9,13 @@ module Pretty where import qualified Data.Text as Text -import Data.Text (Text) +import Data.Text (Text, pack) import Text.PrettyPrint hiding ((<>)) +ppToText :: Pretty a => a -> Text +ppToText = pack . show . pp + -- | With this, one can `data X = ...; derive Show via PP X` newtype PP a = PP { unPP :: a } @@ -23,10 +26,20 @@ instance Pretty a => Show (PP a) where class Pretty p where pp :: p -> Doc +class Pretty1 p where + pp1 :: p Doc -> Doc + +instance (Pretty1 p, Functor p, Pretty a) => Pretty (p a) where + pp = pp1 . fmap pp + -- | Common instance. instance Pretty Text where pp = text . Text.unpack +-- | Common instance. +instance Pretty Doc where + pp = id + tuple :: Pretty p => [p] -> Doc tuple = parens . train "," diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index 4ba76382f..b927923a0 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/tools/lsp/squirrel/src/Range.hs @@ -22,4 +22,4 @@ instance Pretty Range where int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc class HasRange a where - location :: Lens' a Range \ No newline at end of file + getRange :: a -> Range \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Stubbed.hs b/tools/lsp/squirrel/src/Stubbed.hs new file mode 100644 index 000000000..556e58c67 --- /dev/null +++ b/tools/lsp/squirrel/src/Stubbed.hs @@ -0,0 +1,28 @@ + +module Stubbed where + +import Control.Lens + +import Data.Text (Text, pack) + +import Error + +-- | For types that have a default replacer with an `Error`. +class Stubbed a where + stubbing :: Error -> a + +instance Stubbed Text where + stubbing = pack . show + +-- | This is bad, but I had to. +-- +-- TODO: Find a way to remove this instance. +-- I probably need a wrapper around '[]'. +-- +instance Stubbed [a] where + stubbing = const [] + +-- | `Nothing` would be bad default replacer. +instance Stubbed a => Stubbed (Maybe a) where + stubbing = Just . stubbing + diff --git a/tools/lsp/squirrel/src/Tree.hs b/tools/lsp/squirrel/src/Tree.hs new file mode 100644 index 000000000..5fdd932d1 --- /dev/null +++ b/tools/lsp/squirrel/src/Tree.hs @@ -0,0 +1,105 @@ + +module Tree where + +import Data.Fix +import Data.Functor.Compose + +import Union +import Update +import Lattice +import HasComments +import HasErrors +import Pretty +import Error +import Stubbed + +-- | Tree is a fixpoint of `Union` @layers@, each equipped with an @info@. +newtype Tree layers info = Tree + { unTree :: Fix (Either Error `Compose` (,) info `Compose` Union layers) + } + +instance (Functor (Union layers)) => Functor (Tree layers) where + fmap f (Tree fixpoint) = Tree $ cata (Fix . go) fixpoint + where + go (Compose (Left err)) = Compose $ Left err + go (Compose (Right (Compose (a, rest)))) = + Compose $ Right $ Compose (f a, rest) + +instance + ( Functor (Union layers) + , HasComments info + , Pretty (Union layers Doc) + ) + => + Show (Tree layers info) + where + show = show . pp + +instance {-# OVERLAPS #-} + ( HasComments info + , Functor (Union fs) + , Pretty (Union fs Doc) + ) + => + Pretty (Tree fs info) + where + pp (Tree it) = cata aux it + where + aux (Compose (Left err)) = pp err + aux (Compose (Right (Compose (info, fTree)))) = c info $ pp fTree + +-- Return all subtrees that cover the range, ascending in side. +spineTo + :: ( Lattice info + , Foldable (Union fs) + ) + => info + -> Tree fs info + -> [Tree fs info] +spineTo info = reverse . go . unTree + where + go tree@(Fix (Compose (Right (Compose (info', fres))))) = + -- traceShow (info (a -> m b) + -> Tree fs a -> m (Tree fs b) +updateTree act = fmap Tree . go . unTree + where + go (Fix (Compose (Right (Compose (a, union))))) = do + b <- act a + before (Tree <$> union) + union' <- traverse go union + after (Tree <$> union) + return (Fix (Compose (Right (Compose (b, union'))))) + + go (Fix (Compose (Left err))) = do + return (Fix (Compose (Left err))) + +-- | Make a tree out of a layer and an info. +mk :: (Functor f, Member f fs) => info -> f (Tree fs info) -> Tree fs info +mk i fx = Tree $ Fix $ Compose $ Right $ Compose (i, inj $ fmap unTree fx) + +infoOf :: Tree fs info -> Maybe info +infoOf (Tree (Fix (Compose it))) = + either + (const Nothing) + (Just . fst . getCompose) it + +instance Stubbed (Tree fs info) where + stubbing = Tree . Fix . Compose . Left + +instance Foldable (Union fs) => HasErrors (Tree fs info) where + errors = go . unTree + where + go (Fix (Compose (Left err))) = pure err + go (Fix rest) = foldMap go rest \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Union.hs b/tools/lsp/squirrel/src/Union.hs new file mode 100644 index 000000000..99eedd2b1 --- /dev/null +++ b/tools/lsp/squirrel/src/Union.hs @@ -0,0 +1,77 @@ + +module Union + ( Union(..), eliminate + , Member, proj, inj + ) + where + +import Update +import Pretty + +{- + The "one of" datatype. + Each `Union fs a` is a `f a`, where `f` is one of `fs`. +-} +data Union fs x where + Here :: f x -> Union (f : fs) x + There :: Union fs x -> Union (f : fs) x + +instance Eq (Union '[] a) where (==) = error "Union.empty" +instance Show (Union '[] a) where show = error "Union.empty" + +instance Functor (Union '[]) where fmap = error "Union.empty" +instance Foldable (Union '[]) where foldMap = error "Union.empty" +instance Traversable (Union '[]) where traverse = error "Union.empty" + +instance (Eq (f a), Eq (Union fs a)) => Eq (Union (f : fs) a) where + a == b = case (a, b) of + (Here a', Here b') -> a' == b' + (There a', There b') -> a' == b' + _ -> False + +instance (Show (f a), Show (Union fs a)) => Show (Union (f : fs) a) where + show = eliminate show show + +deriving stock instance (Functor f, Functor (Union fs)) => Functor (Union (f : fs)) +deriving stock instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f : fs)) +deriving stock instance (Traversable f, Traversable (Union fs)) => Traversable (Union (f : fs)) + +{- + A case over `Union`. +-} +eliminate + :: (f x -> a) + -> (Union fs x -> a) + -> (Union (f : fs) x -> a) +eliminate here there = \case + Here fx -> here fx + There rest -> there rest + +{- + The `f` functior is in the `fs` list. +-} +class Member f fs where + inj :: f x -> Union fs x -- embed f into some Union + proj :: Union fs x -> Maybe (f x) -- check if a Union is actually f + +instance {-# OVERLAPS #-} Member f (f : fs) where + inj = Here + proj = eliminate Just (const Nothing) + +instance Member f fs => Member f (g : fs) where + inj = There . inj + proj = eliminate (const Nothing) proj + +instance HasMethods m => UpdateOver m (Union '[]) a where + before = error "Union.empty" + after = error "Union.empty" + +instance (HasMethods m, UpdateOver m f a, UpdateOver m (Union fs) a) => UpdateOver m (Union (f : fs)) a where + before = eliminate before before + after = eliminate after after + +instance Pretty1 (Union '[]) where + pp1 = error "Union.empty" + +instance (Pretty1 f, Pretty1 (Union fs)) => Pretty1 (Union (f : fs)) where + pp1 = eliminate pp1 pp1 \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Update.hs b/tools/lsp/squirrel/src/Update.hs new file mode 100644 index 000000000..52ddab008 --- /dev/null +++ b/tools/lsp/squirrel/src/Update.hs @@ -0,0 +1,22 @@ + +module Update where + +{- + Abstraction over monad capabilities. +-} +class Monad m => HasMethods m where + data Methods m :: * + method :: Methods m + +{- + Given some AST structure, do some stuff before & after it is traversed. +-} +class HasMethods m => UpdateOver m f a where + before :: f a -> m () + after :: f a -> m () + + before _ = skip + after _ = skip + +skip :: Monad m => m () +skip = return () \ No newline at end of file