balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Convert to monotyped AST

Browse Source
This commit is contained in:
Kirill Andreev 2020-06-01 18:17:33 +04:00
parent 113a2425a4
commit d380e46737
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
19 changed files with 1334 additions and 1773 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
tools/lsp/squirrel/app/Main.hs
View File

@ -27,6 +27,7 @@ import ParseTree
import Parser import Parser
import Range import Range
import AST import AST
import HasErrors
import Pretty import Pretty
main :: IO () main :: IO ()

27
tools/lsp/squirrel/package.yaml
View File

@ -4,29 +4,38 @@ dependencies:
- base - base
- bytestring - bytestring
- data-default - data-default
- data-fix
- lens - lens
- mtl - mtl
- pretty
- template-haskell - template-haskell
- text - text
- tree-sitter - tree-sitter
- pretty
default-extensions: default-extensions:
- LambdaCase - BangPatterns
- BlockArguments - BlockArguments
- OverloadedStrings - DataKinds
- GeneralisedNewtypeDeriving - DeriveFoldable
- DeriveFunctor
- DeriveTraversable
- DerivingStrategies - DerivingStrategies
- DerivingVia - DerivingVia
- FlexibleContexts
- FlexibleInstances - FlexibleInstances
- GADTs
- GeneralisedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns - NamedFieldPuns
- BangPatterns - OverloadedStrings
- ScopedTypeVariables
- QuasiQuotes - QuasiQuotes
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell - TemplateHaskell
- DeriveFunctor - TypeFamilies
- DeriveFoldable - TypeOperators
- DeriveTraversable - UndecidableInstances
ghc-options: -freverse-errors -Wall -threaded ghc-options: -freverse-errors -Wall -threaded

14
tools/lsp/squirrel/squirrel.cabal
View File

@ -1,10 +1,10 @@
cabal-version: 1.12 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 -- see: https://github.com/sol/hpack
-- --
-- hash: e30e95968ee812129049606c1bdd5ab3a97ce79d1da5f70f38adaf4bc91f4a4a -- hash: fc91e2bbafd609769dba91a90992c659e68f017fa28f156cd261cd553083a47d
name: squirrel name: squirrel
version: 0.0.0 version: 0.0.0
@ -17,16 +17,20 @@ library
AST.Parser AST.Parser
AST.Scope AST.Scope
AST.Types AST.Types
Lattice
Parser Parser
ParseTree ParseTree
Pretty Pretty
Range Range
TH TH
Tree
Union
Update
other-modules: other-modules:
Paths_squirrel Paths_squirrel
hs-source-dirs: hs-source-dirs:
src/ 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 ghc-options: -freverse-errors -Wall -threaded
include-dirs: include-dirs:
vendor vendor
@ -36,6 +40,7 @@ library
base base
, bytestring , bytestring
, data-default , data-default
, data-fix
, lens , lens
, mtl , mtl
, pretty , pretty
@ -50,12 +55,13 @@ executable squirrel
Paths_squirrel Paths_squirrel
hs-source-dirs: hs-source-dirs:
app/ 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 ghc-options: -freverse-errors -Wall -threaded
build-depends: build-depends:
base base
, bytestring , bytestring
, data-default , data-default
, data-fix
, haskell-lsp , haskell-lsp
, hslogger , hslogger
, interpolate , interpolate

1
tools/lsp/squirrel/src/AST.hs
View File

@ -3,5 +3,4 @@ module AST (module M) where
import AST.Types as M import AST.Types as M
import AST.Parser as M import AST.Parser as M
import AST.Errors as M
import AST.Scope as M import AST.Scope as M

292
tools/lsp/squirrel/src/AST/Errors.hs
View File

@ -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

502
tools/lsp/squirrel/src/AST/Parser.hs
View File

@ -15,64 +15,84 @@ import AST.Types hiding (tuple)
import Parser import Parser
import Range import Range
import Tree
import Union
import Debug.Trace 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 = contract =
ctor Contract ranged do
pure Contract
<*> subtree "contract" do <*> subtree "contract" do
many do many do
inside "declaration:" do inside "declaration:" do
declaration declaration
name :: Parser (Name ASTInfo) name :: Parser (Pascal ASTInfo)
name = ctor Name <*> token "Name" name = ranged do pure Name <*> token "Name"
capitalName :: Parser (Name ASTInfo) capitalName :: Parser (Pascal ASTInfo)
capitalName = ctor Name <*> token "Name_Capital" capitalName = ranged do pure Name <*> token "Name_Capital"
declaration :: Parser (Declaration ASTInfo) declaration :: Parser (Pascal ASTInfo)
declaration declaration
= do ctor ValueDecl <*> binding = do ranged do pure ValueDecl <*> binding
<|> do ctor ValueDecl <*> vardecl <|> do ranged do pure ValueDecl <*> vardecl
<|> do ctor ValueDecl <*> constdecl <|> do ranged do pure ValueDecl <*> constdecl
<|> do typedecl <|> do typedecl
<|> do ctor Action <*> attributes <|> do ranged do pure Action <*> attributes
<|> do include <|> do include
include = do include = do
subtree "include" do subtree "include" do
ctor Include ranged do
<*> inside "filename" do token "String" pure Include
<*> inside "filename" do
token "String"
typedecl :: Parser (Declaration ASTInfo) typedecl :: Parser (Pascal ASTInfo)
typedecl = do typedecl = do
subtree "type_decl" do subtree "type_decl" do
ctor TypeDecl ranged do
pure TypeDecl
<*> inside "typeName:" name <*> inside "typeName:" name
<*> inside "typeValue:" newtype_ <*> inside "typeValue:" newtype_
vardecl :: Parser (Binding ASTInfo) vardecl :: Parser (Pascal ASTInfo)
vardecl = do vardecl = do
subtree "var_decl" do subtree "var_decl" do
ctor Var ranged do
pure Var
<*> inside "name" name <*> inside "name" name
<*> inside "type" type_ <*> inside "type" type_
<*> inside "value" expr <*> inside "value" expr
constdecl :: Parser (Binding ASTInfo) constdecl :: Parser (Pascal ASTInfo)
constdecl = do constdecl = do
subtree "const_decl" do subtree "const_decl" do
ctor Const ranged do
pure Const
<*> inside "name" name <*> inside "name" name
<*> inside "type" type_ <*> inside "type" type_
<*> inside "value" expr <*> inside "value" expr
binding :: Parser (Binding ASTInfo) binding :: Parser (Pascal ASTInfo)
binding = do binding = do
inside ":fun_decl" do inside ":fun_decl" do
ctor Function ranged do
pure Function
<*> recursive <*> recursive
<*> inside "name:" name <*> inside "name:" name
<*> inside "parameters:parameters" do <*> inside "parameters:parameters" do
@ -88,12 +108,14 @@ recursive = do
return $ maybe False (== "recursive") mr return $ maybe False (== "recursive") mr
expr :: Parser (Expr ASTInfo) expr :: Parser (Pascal ASTInfo)
expr = stubbed "expr" do expr = stubbed "expr" do
select select
[ -- Wait, isn't it `qname`? TODO: replace. [ -- Wait, isn't it `qname`? TODO: replace.
ctor Ident <*> do ranged do
ctor QualifiedName pure Ident <*> do
ranged do
pure QualifiedName
<*> name <*> name
<*> pure [] <*> pure []
, opCall , opCall
@ -133,48 +155,56 @@ expr = stubbed "expr" do
, set_remove , set_remove
] ]
set_remove :: Parser (Expr ASTInfo) set_remove :: Parser (Pascal ASTInfo)
set_remove = do set_remove = do
subtree "set_remove" do subtree "set_remove" do
ctor SetRemove ranged do
pure SetRemove
<*> inside "key" expr <*> inside "key" expr
<*> inside "container" do <*> inside "container" do
inside ":path" do inside ":path" do
qname <|> projection qname <|> projection
set_patch :: Parser (Pascal ASTInfo)
set_patch = do set_patch = do
subtree "set_patch" do subtree "set_patch" do
ctor SetPatch ranged do
pure SetPatch
<*> inside "container:path" (qname <|> projection) <*> inside "container:path" (qname <|> projection)
<*> many do inside "key" expr <*> many do inside "key" expr
record_update = do record_update = do
subtree "update_record" do subtree "update_record" do
ctor RecordUpd ranged do
pure RecordUpd
<*> inside "record:path" do qname <|> projection <*> inside "record:path" do qname <|> projection
<*> many do inside "assignment" field_path_assignment <*> many do inside "assignment" field_path_assignment
field_path_assignment = do field_path_assignment = do
subtree "field_path_assignment" do subtree "field_path_assignment" do
ctor FieldAssignment ranged do
pure FieldAssignment
<*> inside "lhs:path" do qname <|> projection <*> inside "lhs:path" do qname <|> projection
<*> inside "_rhs" expr <*> inside "_rhs" expr
map_patch = do map_patch = do
subtree "map_patch" do subtree "map_patch" do
ctor MapPatch ranged do
pure MapPatch
<*> inside "container:path" (qname <|> projection) <*> inside "container:path" (qname <|> projection)
<*> many do inside "binding" map_binding <*> many do inside "binding" map_binding
set_expr :: Parser (Expr ASTInfo) set_expr :: Parser (Pascal ASTInfo)
set_expr = do set_expr = do
subtree "set_expr" do subtree "set_expr" do
ctor List <*> many do ranged do
pure List <*> many do
inside "element" expr inside "element" expr
lambda_expr = do lambda_expr = do
subtree "fun_expr" do subtree "fun_expr" do
ctor Lambda ranged do
pure Lambda
<*> inside "parameters:parameters" do <*> inside "parameters:parameters" do
many do inside "parameter" paramDecl many do inside "parameter" paramDecl
<*> inside "type" newtype_ <*> inside "type" newtype_
@ -182,7 +212,8 @@ lambda_expr = do
seq_expr = do seq_expr = do
subtree "block" do subtree "block" do
ctor Seq <*> many do ranged do
pure Seq <*> many do
inside "statement" do inside "statement" do
declaration <|> statement declaration <|> statement
@ -192,7 +223,8 @@ loop = do
for_container = do for_container = do
subtree "for_loop" do subtree "for_loop" do
ctor ForBox ranged do
pure ForBox
<*> inside "key" name <*> inside "key" name
<*> optional do inside "value" name <*> optional do inside "value" name
<*> inside "kind" anything <*> inside "kind" anything
@ -201,13 +233,15 @@ for_container = do
while_loop = do while_loop = do
subtree "while_loop" do subtree "while_loop" do
ctor WhileLoop ranged do
pure WhileLoop
<*> inside "breaker" expr <*> inside "breaker" expr
<*> inside "body" expr <*> inside "body" expr
for_loop = do for_loop = do
subtree "for_loop" do subtree "for_loop" do
ctor ForLoop ranged do
pure ForLoop
<*> inside "name" name <*> inside "name" name
<*> inside "begin" expr <*> inside "begin" expr
<*> inside "end" expr <*> inside "end" expr
@ -216,57 +250,66 @@ for_loop = do
clause_block = do clause_block = do
subtree "clause_block" do subtree "clause_block" do
inside "block:block" do inside "block:block" do
ctor Seq <*> many do ranged do
pure Seq <*> many do
inside "statement" (declaration <|> statement) inside "statement" (declaration <|> statement)
<|> do <|> do
subtree "clause_block" do subtree "clause_block" do
ctor Seq <*> many do ranged do
pure Seq <*> many do
inside "statement" (declaration <|> statement) inside "statement" (declaration <|> statement)
skip :: Parser (Expr ASTInfo) skip :: Parser (Pascal ASTInfo)
skip = do 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 case_action = do
subtree "case_instr" do subtree "case_instr" do
ctor Case ranged do
pure Case
<*> inside "subject" expr <*> inside "subject" expr
<*> many do <*> many do
inside "case" alt_action inside "case" alt_action
alt_action :: Parser (Alt ASTInfo) alt_action :: Parser (Pascal ASTInfo)
alt_action = do alt_action = do
subtree "case_clause_instr" do subtree "case_clause_instr" do
ctor Alt ranged do
pure Alt
<*> inside "pattern" pattern <*> inside "pattern" pattern
<*> inside "body:if_clause" expr <*> inside "body:if_clause" expr
case_expr :: Parser (Expr ASTInfo) case_expr :: Parser (Pascal ASTInfo)
case_expr = do case_expr = do
subtree "case_expr" do subtree "case_expr" do
ctor Case ranged do
pure Case
<*> inside "subject" expr <*> inside "subject" expr
<*> many do <*> many do
inside "case" alt inside "case" alt
alt :: Parser (Alt ASTInfo) alt :: Parser (Pascal ASTInfo)
alt = do alt = do
subtree "case_clause_expr" do subtree "case_clause_expr" do
ctor Alt ranged do
pure Alt
<*> inside "pattern" pattern <*> inside "pattern" pattern
<*> inside "body" expr <*> inside "body" expr
pattern :: Parser (Pattern ASTInfo) pattern :: Parser (Pascal ASTInfo)
pattern = do pattern = do
subtree "pattern" $ do subtree "pattern" $ do
inside "the" core_pattern inside "the" core_pattern
<|> <|>
do ctor IsCons do ranged do
pure IsCons
<*> inside "head" core_pattern <*> inside "head" core_pattern
<*> inside "tail" pattern <*> inside "tail" pattern
core_pattern :: Parser (Pattern ASTInfo) core_pattern :: Parser (Pascal ASTInfo)
core_pattern core_pattern
= constr_pattern = constr_pattern
<|> string_pattern <|> string_pattern
@ -277,63 +320,84 @@ core_pattern
<|> some_pattern <|> some_pattern
<|> var_pattern <|> var_pattern
var_pattern :: Parser (Pattern ASTInfo) var_pattern :: Parser (Pascal ASTInfo)
var_pattern = var_pattern =
ctor IsVar <*> name ranged do
pure IsVar <*> name
some_pattern :: Parser (Pattern ASTInfo) some_pattern :: Parser (Pascal ASTInfo)
some_pattern = do some_pattern = do
subtree "Some_pattern" do subtree "Some_pattern" do
ctor IsConstr ranged do
<*> do inside "constr" do ctor Name <*> token "Some" pure IsConstr
<*> inside "constr" do
ranged do
pure Name <*> token "Some"
<*> do Just <$> inside "arg" pattern <*> do Just <$> inside "arg" pattern
string_pattern :: Parser (Pattern ASTInfo) string_pattern :: Parser (Pascal ASTInfo)
string_pattern = string_pattern =
ctor IsConstant <*> do ranged do
ctor String <*> token "String" pure IsConstant <*> do
ranged do
pure String <*> token "String"
nat_pattern :: Parser (Pattern ASTInfo) nat_pattern :: Parser (Pascal ASTInfo)
nat_pattern = nat_pattern =
ctor IsConstant <*> do ranged do
ctor Nat <*> token "Nat" pure IsConstant <*> do
ranged do
pure Nat <*> token "Nat"
int_pattern :: Parser (Pattern ASTInfo) int_pattern :: Parser (Pascal ASTInfo)
int_pattern = int_pattern =
ctor IsConstant <*> do ranged do
ctor Int <*> token "Int" pure IsConstant <*> do
ranged do
pure Int <*> token "Int"
constr_pattern :: Parser (Pattern ASTInfo) constr_pattern :: Parser (Pascal ASTInfo)
constr_pattern = constr_pattern =
do do
subtree "user_constr_pattern" do subtree "user_constr_pattern" do
ctor IsConstr ranged do
pure IsConstr
<*> inside "constr:constr" capitalName <*> inside "constr:constr" capitalName
<*> optional do <*> optional do
inside "arguments" tuple_pattern inside "arguments" tuple_pattern
<|> <|>
do do
ctor IsConstr ranged do
<*> do ctor Name <*> do true <|> false <|> none <|> unit pure IsConstr
<*> ranged do
pure Name <*> do
true <|> false <|> none <|> unit
<*> pure Nothing <*> pure Nothing
tuple_pattern :: Parser (Pattern ASTInfo) tuple_pattern :: Parser (Pascal ASTInfo)
tuple_pattern = do tuple_pattern = do
subtree "tuple_pattern" do subtree "tuple_pattern" do
ctor IsTuple <*> many do ranged do
pure IsTuple <*> many do
inside "element" pattern inside "element" pattern
list_pattern :: Parser (Pattern ASTInfo) list_pattern :: Parser (Pascal ASTInfo)
list_pattern = do list_pattern = do
subtree "list_pattern" do subtree "list_pattern" do
ctor IsList <*> many do ranged do
pure IsList <*> many do
inside "element" pattern inside "element" pattern
nullary_ctor :: Parser (Expr ASTInfo) nullary_ctor :: Parser (Pascal ASTInfo)
nullary_ctor = do nullary_ctor = do
ctor Ident <*> do ranged do
ctor QualifiedName pure Ident <*> do
<*> do ctor Name <*> do true <|> false <|> none <|> unit ranged do
pure QualifiedName
<*> ranged do
pure Name <*> do
true <|> false <|> none <|> unit
<*> pure [] <*> pure []
true = token "True" true = token "True"
@ -341,286 +405,340 @@ false = token "False"
none = token "None" none = token "None"
unit = token "Unit" unit = token "Unit"
nat_literal :: Parser (Expr ASTInfo) nat_literal :: Parser (Pascal ASTInfo)
nat_literal = do nat_literal = do
ctor Constant <*> do ranged do
ctor Nat <*> token "Nat" pure Constant <*> do
ranged do
pure Nat <*> token "Nat"
bytes_literal :: Parser (Expr ASTInfo) bytes_literal :: Parser (Pascal ASTInfo)
bytes_literal = do bytes_literal = do
ctor Constant <*> do ranged do
ctor Bytes <*> token "Bytes" pure Constant <*> do
ranged do
pure Bytes <*> token "Bytes"
constr_call :: Parser (Expr ASTInfo) constr_call :: Parser (Pascal ASTInfo)
constr_call = do constr_call = do
some_call <|> user_constr_call some_call <|> user_constr_call
where where
some_call = do some_call = do
subtree "Some_call" do subtree "Some_call" do
ctor Apply ranged do
<*> do ctor Ident <*> inside "constr" qname' pure Apply
<*> ranged do
pure Ident <*> inside "constr" qname'
<*> inside "arguments:arguments" do <*> inside "arguments:arguments" do
many do inside "argument" expr many do inside "argument" expr
user_constr_call = do user_constr_call = do
subtree "constr_call" do subtree "constr_call" do
ctor Apply ranged do
pure Apply
<*> inside "constr:constr" do <*> inside "constr:constr" do
ctor Ident <*> do ranged do
ctor QualifiedName pure Ident <*> do
ranged do
pure QualifiedName
<*> capitalName <*> capitalName
<*> pure [] <*> pure []
<*> inside "arguments:arguments" do <*> inside "arguments:arguments" do
many do inside "argument" expr many do
inside "argument" expr
indexing :: Parser (Expr ASTInfo) indexing :: Parser (Pascal ASTInfo)
indexing = do indexing = do
subtree "map_lookup" do subtree "map_lookup" do
ctor Indexing ranged do
pure Indexing
<*> inside "container:path" do <*> inside "container:path" do
qname <|> projection qname <|> projection
<*> inside "index" expr <*> inside "index" expr
map_remove :: Parser (Expr ASTInfo) map_remove :: Parser (Pascal ASTInfo)
map_remove = do map_remove = do
subtree "map_remove" do subtree "map_remove" do
ctor MapRemove ranged do
pure MapRemove
<*> inside "key" expr <*> inside "key" expr
<*> inside "container" do <*> inside "container" do
inside ":path" do inside ":path" do
qname <|> projection qname <|> projection
big_map_expr :: Parser (Expr ASTInfo) big_map_expr :: Parser (Pascal ASTInfo)
big_map_expr = do big_map_expr = do
subtree "big_map_injection" do subtree "big_map_injection" do
ctor BigMap <*> many do ranged do
pure BigMap <*> many do
inside "binding" do inside "binding" do
map_binding map_binding
map_expr :: Parser (Expr ASTInfo) map_expr :: Parser (Pascal ASTInfo)
map_expr = do map_expr = do
subtree "map_injection" do subtree "map_injection" do
ctor Map <*> many do ranged do
pure Map <*> many do
inside "binding" do inside "binding" do
map_binding map_binding
map_binding :: Parser (MapBinding ASTInfo) map_binding :: Parser (Pascal ASTInfo)
map_binding = do map_binding = do
subtree "binding" do subtree "binding" do
ctor MapBinding ranged do
pure MapBinding
<*> inside "key" expr <*> inside "key" expr
<*> inside "value" expr <*> inside "value" expr
moduleQualified :: Parser (Expr ASTInfo) moduleQualified :: Parser (Pascal ASTInfo)
moduleQualified = do moduleQualified = do
subtree "module_field" do subtree "module_field" do
ctor Ident <*> do ranged do
ctor QualifiedName pure Ident <*> do
ranged do
pure QualifiedName
<*> inside "module" capitalName <*> inside "module" capitalName
<*> do pure <$> do ctor At <*> inside "method" do name <|> name' <*> do pure <$> ranged do
pure At <*> inside "method" do name <|> name'
tuple_expr :: Parser (Expr ASTInfo) tuple_expr :: Parser (Pascal ASTInfo)
tuple_expr = do tuple_expr = do
subtree "tuple_expr" do subtree "tuple_expr" do
ctor Tuple <*> many do ranged do
pure Tuple <*> many do
inside "element" expr inside "element" expr
attributes :: Parser (Expr ASTInfo) attributes :: Parser (Pascal ASTInfo)
attributes = do attributes = do
subtree "attr_decl" do subtree "attr_decl" do
ctor Attrs <*> many do ranged do
pure Attrs <*> many do
inside "attribute" do inside "attribute" do
token "String" token "String"
string_literal :: Parser (Expr ASTInfo) string_literal :: Parser (Pascal ASTInfo)
string_literal = do string_literal = do
ctor Constant <*> do ranged do
ctor String <*> pure Constant <*> do
ranged do
pure String <*> do
token "String" token "String"
has_type :: Parser (Expr ASTInfo) has_type :: Parser (Pascal ASTInfo)
has_type = do has_type = do
subtree "annot_expr" do subtree "annot_expr" do
ctor Annot ranged do
pure Annot
<*> inside "subject" expr <*> inside "subject" expr
<*> inside "type" type_ <*> inside "type" type_
list_expr :: Parser (Expr ASTInfo) list_expr :: Parser (Pascal ASTInfo)
list_expr = do list_expr = do
subtree "list_expr" do subtree "list_expr" do
ctor List <*> many do ranged do
pure List <*> many do
inside "element" expr inside "element" expr
qname :: Parser (QualifiedName ASTInfo) qname :: Parser (Pascal ASTInfo)
qname = do qname = do
ctor QualifiedName ranged do
pure QualifiedName
<*> name <*> name
<*> pure [] <*> pure []
qname' :: Parser (QualifiedName ASTInfo) qname' :: Parser (Pascal ASTInfo)
qname' = do qname' = do
ctor QualifiedName ranged do
pure QualifiedName
<*> name' <*> name'
<*> pure [] <*> pure []
assign :: Parser (Expr ASTInfo) assign :: Parser (Pascal ASTInfo)
assign = do assign = do
subtree "assignment" do subtree "assignment" do
ctor Assign ranged do
pure Assign
<*> inside "LHS" lhs <*> inside "LHS" lhs
<*> inside "RHS" expr <*> inside "RHS" expr
lhs :: Parser (LHS ASTInfo) lhs :: Parser (Pascal ASTInfo)
lhs = lhs =
do ctor LHS ranged do
pure LHS
<*> inside "container:path" do <*> inside "container:path" do
qname <|> projection qname <|> projection
<*> pure Nothing <*> pure Nothing
<|> <|>
do ctor LHS ranged do
pure LHS
<*> subtree "path" do <*> subtree "path" do
qname <|> projection qname <|> projection
<*> pure Nothing <*> pure Nothing
<|> <|>
do subtree "map_lookup" do subtree "map_lookup" do
ctor LHS ranged do
pure LHS
<*> inside "container:path" do <*> inside "container:path" do
qname <|> projection qname <|> projection
<*> inside "index" do <*> inside "index" do
Just <$> expr Just <$> expr
tez_literal :: Parser (Expr ASTInfo) tez_literal :: Parser (Pascal ASTInfo)
tez_literal = do tez_literal = do
ctor Constant <*> do ranged do
ctor Tez <*> token "Tez" pure Constant <*> do
ranged do
pure Tez <*> token "Tez"
if_expr :: Parser (Expr ASTInfo) if_expr :: Parser (Pascal ASTInfo)
if_expr = do if_expr = do
subtree "conditional" do subtree "conditional" do
ctor If ranged do
pure If
<*> inside "selector" expr <*> inside "selector" expr
<*> inside "then:if_clause" expr <*> inside "then:if_clause" expr
<*> inside "else:if_clause" expr <*> inside "else:if_clause" expr
<|> do <|> do
subtree "cond_expr" do subtree "cond_expr" do
ctor If ranged do
pure If
<*> inside "selector" expr <*> inside "selector" expr
<*> inside "then" expr <*> inside "then" expr
<*> inside "else" expr <*> inside "else" expr
method_call :: Parser (Expr ASTInfo) method_call :: Parser (Pascal ASTInfo)
method_call = do method_call = do
subtree "projection_call" do subtree "projection_call" do
ctor apply' ranged do
pure apply'
<*> getInfo
<*> inside "f" projection <*> inside "f" projection
<*> optional do inside "arguments" arguments <*> optional do inside "arguments" arguments
where where
apply' r f (Just xs) = Apply r (Ident r f) xs apply' i f (Just xs) = Apply (mk i $ Ident f) xs
apply' r f _ = Ident r f apply' i f _ = Ident f
projection :: Parser (QualifiedName ASTInfo) projection :: Parser (Pascal ASTInfo)
projection = do projection = do
subtree "data_projection" do subtree "data_projection" do
ctor QualifiedName ranged do
pure QualifiedName
<*> inside "struct" name <*> inside "struct" name
<*> many selection <*> many selection
selection :: Parser (Path ASTInfo) selection :: Parser (Pascal ASTInfo)
selection = do selection = do
inside "index:selection" inside "index:selection"
$ do ctor At <*> name $ ranged do pure At <*> name
<|> do ctor Ix <*> token "Int" <|> ranged do pure Ix <*> token "Int"
<|> <|>
inside "index" do 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 par_call = do
subtree "par_call" do subtree "par_call" do
ctor apply' pure apply'
<*> getInfo
<*> inside "f" expr <*> inside "f" expr
<*> optional do inside "arguments" arguments <*> optional do inside "arguments" arguments
where where
apply' r f (Just xs) = Apply r f xs apply'
apply' _ f _ = f :: 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 int_literal = do
ctor Constant ranged do
<*> do ctor Int <*> token "Int" pure Constant
<*> ranged do
pure Int <*> token "Int"
record_expr :: Parser (Expr ASTInfo) record_expr :: Parser (Pascal ASTInfo)
record_expr = do record_expr = do
subtree "record_expr" do subtree "record_expr" do
ctor Record <*> many do ranged do
pure Record <*> many do
inside "assignment:field_assignment" do inside "assignment:field_assignment" do
ctor Assignment ranged do
pure Assignment
<*> inside "name" name <*> inside "name" name
<*> inside "_rhs" expr <*> inside "_rhs" expr
fun_call :: Parser (Expr ASTInfo) fun_call :: Parser (Pascal ASTInfo)
fun_call = do fun_call = do
subtree "fun_call" do subtree "fun_call" do
ctor Apply ranged do
<*> do ctor Ident <*> inside "f" function_id pure Apply
<*> ranged do pure Ident <*> inside "f" function_id
<*> inside "arguments" arguments <*> inside "arguments" arguments
arguments = arguments =
subtree "arguments" do subtree "arguments" do
many do inside "argument" expr many do inside "argument" expr
function_id :: Parser (QualifiedName ASTInfo) function_id :: Parser (Pascal ASTInfo)
function_id = select function_id = select
[ qname [ qname
, do , do
subtree "module_field" do subtree "module_field" do
ctor QualifiedName ranged do
pure QualifiedName
<*> inside "module" capitalName <*> inside "module" capitalName
<*> do pure <$> do ctor At <*> inside "method" do name <|> name' <*> do pure <$> ranged do
pure At <*> inside "method" do name <|> name'
] ]
opCall :: Parser (Expr ASTInfo) opCall :: Parser (Pascal ASTInfo)
opCall = do opCall = do
subtree "op_expr" subtree "op_expr"
$ do inside "the" expr $ do inside "the" expr
<|> do ctor BinOp <|> ranged do
pure BinOp
<*> inside "arg1" expr <*> inside "arg1" expr
<*> inside "op" anything <*> inside "op" anything
<*> inside "arg2" expr <*> inside "arg2" expr
<|> do ctor UnOp <|> ranged do
pure UnOp
<*> inside "negate" anything <*> inside "negate" anything
<*> inside "arg" expr <*> inside "arg" expr
letExpr = do letExpr = do
subtree "let_expr" do subtree "let_expr" do
ctor let' pure let'
<*> getInfo
<*> optional do <*> optional do
inside "locals:block" do inside "locals:block" do
many do many do
inside "statement" do inside "statement" do
declaration <|> statement declaration <|> statement
<*> inside "body"expr <*> inside "body"expr
where where
let' r decls body = case decls of let' r decls body = case decls of
Just them -> Let r them body Just them -> mk r $ Let them body
Nothing -> body Nothing -> body
statement :: Parser (Declaration ASTInfo) statement :: Parser (Pascal ASTInfo)
statement = ctor Action <*> expr statement = ranged do pure Action <*> expr
paramDecl :: Parser (VarDecl ASTInfo) paramDecl :: Parser (Pascal ASTInfo)
paramDecl = do paramDecl = do
subtree "param_decl" do subtree "param_decl" do
ctor Decl ranged do
pure Decl
<*> inside "access" do <*> inside "access" do
ctor access' <*> anything ranged do
pure access' <*> anything
<*> inside "name" name <*> inside "name" name
<*> inside "type" type_ <*> inside "type" type_
where where
access' r "var" = Mutable r access' "var" = Mutable
access' r "const" = Immutable r access' "const" = Immutable
newtype_ = select newtype_ = select
[ record_type [ record_type
@ -630,70 +748,78 @@ newtype_ = select
sum_type = do sum_type = do
subtree "sum_type" do subtree "sum_type" do
ctor TSum <*> many do ranged do
pure TSum <*> many do
inside "variant" variant inside "variant" variant
variant = do variant = do
subtree "variant" do subtree "variant" do
ctor Variant ranged do
pure Variant
<*> inside "constructor:constr" capitalName <*> inside "constructor:constr" capitalName
<*> optional do inside "arguments" type_ <*> optional do inside "arguments" type_
record_type = do record_type = do
subtree "record_type" do subtree "record_type" do
ctor TRecord <*> many do ranged do
pure TRecord <*> many do
inside "field" do inside "field" do
field_decl field_decl
field_decl = do field_decl = do
subtree "field_decl" do subtree "field_decl" do
ctor TField ranged do
pure TField
<*> inside "fieldName" name <*> inside "fieldName" name
<*> inside "fieldType" newtype_ <*> inside "fieldType" newtype_
type_ :: Parser (Type ASTInfo) type_ :: Parser (Pascal ASTInfo)
type_ = type_ =
fun_type fun_type
where where
fun_type :: Parser (Type ASTInfo) fun_type :: Parser (Pascal ASTInfo)
fun_type = do fun_type = do
inside ":fun_type" do inside ":fun_type" do
ctor tarrow pure tarrow
<*> getInfo
<*> inside "domain" cartesian <*> inside "domain" cartesian
<*> optional do inside "codomain" fun_type <*> optional do inside "codomain" fun_type
where where
tarrow info domain codomain = tarrow i domain codomain =
case codomain of case codomain of
Just co -> TArrow info domain co Just co -> mk i $ TArrow domain co
Nothing -> domain Nothing -> domain
cartesian = do cartesian = do
inside ":cartesian" do inside ":cartesian" do
ctor TProduct <*> some do ranged do
pure TProduct <*> some do
inside "element" do inside "element" do
core_type core_type
core_type = do core_type = do
select select
[ ctor TVar <*> name [ ranged do pure TVar <*> name
, subtree "invokeBinary" do , subtree "invokeBinary" do
ctor TApply ranged do
pure TApply
<*> inside "typeConstr" name' <*> inside "typeConstr" name'
<*> inside "arguments" typeTuple <*> inside "arguments" typeTuple
, subtree "invokeUnary" do , subtree "invokeUnary" do
ctor TApply ranged do
pure TApply
<*> inside "typeConstr" name' <*> inside "typeConstr" name'
<*> do pure <$> inside "arguments" type_ <*> do pure <$> inside "arguments" type_
, subtree "type_expr" newtype_ , subtree "type_expr" newtype_
] ]
name' :: Parser (Name ASTInfo) name' :: Parser (Pascal ASTInfo)
name' = do name' = do
ctor Name <*> anything ranged do pure Name <*> anything
typeTuple :: Parser [Type ASTInfo] typeTuple :: Parser [Pascal ASTInfo]
typeTuple = do typeTuple = do
subtree "type_tuple" do subtree "type_tuple" do
many do inside "element" type_ many do inside "element" type_

1013
tools/lsp/squirrel/src/AST/Scope.hs
View File

File diff suppressed because it is too large Load Diff

555
tools/lsp/squirrel/src/AST/Types.hs
View File

@ -18,408 +18,311 @@ import Data.Void
import Parser import Parser
import ParseTree import ParseTree
import Pretty import Pretty
import Tree
import TH import TH
import Debug.Trace import Debug.Trace
data Contract info data Contract it
= Contract info [Declaration info] = Contract [it]
| WrongContract Error deriving (Show) via PP (Contract it)
deriving (Show) via PP (Contract info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Declaration info data Declaration it
= ValueDecl info (Binding info) = ValueDecl it -- Binding
| TypeDecl info (Name info) (Type info) | TypeDecl it it -- Name Type
| Action info (Expr info) | Action it -- Expr
| Include info Text | Include Text
| WrongDecl Error deriving (Show) via PP (Declaration it)
deriving (Show) via PP (Declaration info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Binding info data Binding it
= Irrefutable info (Pattern info) (Expr info) = Irrefutable it it -- (Pattern) (Expr)
| Function info Bool (Name info) [VarDecl info] (Type info) (Expr info) | Function Bool it [it] it it -- (Name) [VarDecl] (Type) (Expr)
| Var info (Name info) (Type info) (Expr info) | Var it it it -- (Name) (Type) (Expr)
| Const info (Name info) (Type info) (Expr info) | Const it it it -- (Name) (Type) (Expr)
| WrongBinding Error deriving (Show) via PP (Binding it)
deriving (Show) via PP (Binding info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data VarDecl info data VarDecl it
= Decl info (Mutable info) (Name info) (Type info) = Decl it it it -- (Mutable) (Name) (Type)
| WrongVarDecl Error deriving (Show) via PP (VarDecl it)
deriving (Show) via PP (VarDecl info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Mutable info data Mutable it
= Mutable info = Mutable
| Immutable info | Immutable
| WrongMutable Error deriving (Show) via PP (Mutable it)
deriving (Show) via PP (Mutable info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Type info data Type it
= TArrow info (Type info) (Type info) = TArrow it it -- (Type) (Type)
| TRecord info [TField info] | TRecord [it] -- [TField]
| TVar info (Name info) | TVar it -- (Name)
| TSum info [Variant info] | TSum [it] -- [Variant]
| TProduct info [Type info] | TProduct [it] -- [Type]
| TApply info (Name info) [Type info] | TApply it [it] -- (Name) [Type]
| WrongType Error deriving (Show) via PP (Type it)
deriving (Show) via PP (Type info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Variant info data Variant it
= Variant info (Name info) (Maybe (Type info)) = Variant it (Maybe it) -- (Name) (Maybe (Type))
| WrongVariant Error deriving (Show) via PP (Variant it)
deriving (Show) via PP (Variant info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data TField info data TField it
= TField info (Name info) (Type info) = TField it it -- (Name) (Type)
| WrongTField Error deriving (Show) via PP (TField it)
deriving (Show) via PP (TField info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
-- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls. -- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls.
data Expr info data Expr it
= Let info [Declaration info] (Expr info) = Let [it] it -- [Declaration] (Expr)
| Apply info (Expr info) [Expr info] | Apply it [it] -- (Expr) [Expr]
| Constant info (Constant info) | Constant it -- (Constant)
| Ident info (QualifiedName info) | Ident it -- (QualifiedName)
| BinOp info (Expr info) Text (Expr info) | BinOp it Text it -- (Expr) Text (Expr)
| UnOp info Text (Expr info) | UnOp Text it -- (Expr)
| Record info [Assignment info] | Record [it] -- [Assignment]
| If info (Expr info) (Expr info) (Expr info) | If it it it -- (Expr) (Expr) (Expr)
| Assign info (LHS info) (Expr info) | Assign it it -- (LHS) (Expr)
| List info [Expr info] | List [it] -- [Expr]
| Set info [Expr info] | Set [it] -- [Expr]
| Tuple info [Expr info] | Tuple [it] -- [Expr]
| Annot info (Expr info) (Type info) | Annot it it -- (Expr) (Type)
| Attrs info [Text] | Attrs [Text]
| BigMap info [MapBinding info] | BigMap [it] -- [MapBinding]
| Map info [MapBinding info] | Map [it] -- [MapBinding]
| MapRemove info (Expr info) (QualifiedName info) | MapRemove it it -- (Expr) (QualifiedName)
| SetRemove info (Expr info) (QualifiedName info) | SetRemove it it -- (Expr) (QualifiedName)
| Indexing info (QualifiedName info) (Expr info) | Indexing it it -- (QualifiedName) (Expr)
| Case info (Expr info) [Alt info] | Case it [it] -- (Expr) [Alt]
| Skip info | Skip
| ForLoop info (Name info) (Expr info) (Expr info) (Expr info) | ForLoop it it it it -- (Name) (Expr) (Expr) (Expr)
| WhileLoop info (Expr info) (Expr info) | WhileLoop it it -- (Expr) (Expr)
| Seq info [Declaration info] | Seq [it] -- [Declaration]
| Lambda info [VarDecl info] (Type info) (Expr info) | Lambda [it] it it -- [VarDecl] (Type) (Expr)
| ForBox info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info) | ForBox it (Maybe it) Text it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
| MapPatch info (QualifiedName info) [MapBinding info] | MapPatch it [it] -- (QualifiedName) [MapBinding]
| SetPatch info (QualifiedName info) [Expr info] | SetPatch it [it] -- (QualifiedName) [Expr]
| RecordUpd info (QualifiedName info) [FieldAssignment info] | RecordUpd it [it] -- (QualifiedName) [FieldAssignment]
| WrongExpr Error deriving (Show) via PP (Expr it)
deriving (Show) via PP (Expr info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Alt info data Alt it
= Alt info (Pattern info) (Expr info) = Alt it it -- (Pattern) (Expr)
| WrongAlt Error deriving (Show) via PP (Alt it)
deriving (Show) via PP (Alt info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data LHS info data LHS it
= LHS info (QualifiedName info) (Maybe (Expr info)) = LHS it (Maybe it) -- (QualifiedName) (Maybe (Expr))
| WrongLHS Error deriving (Show) via PP (LHS it)
deriving (Show) via PP (LHS info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data MapBinding info data MapBinding it
= MapBinding info (Expr info) (Expr info) = MapBinding it it -- (Expr) (Expr)
| WrongMapBinding Error deriving (Show) via PP (MapBinding it)
deriving (Show) via PP (MapBinding info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Assignment info data Assignment it
= Assignment info (Name info) (Expr info) = Assignment it it -- (Name) (Expr)
| WrongAssignment Error deriving (Show) via PP (Assignment it)
deriving (Show) via PP (Assignment info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data FieldAssignment info data FieldAssignment it
= FieldAssignment info (QualifiedName info) (Expr info) = FieldAssignment it it -- (QualifiedName) (Expr)
| WrongFieldAssignment Error deriving (Show) via PP (FieldAssignment it)
deriving (Show) via PP (FieldAssignment info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Constant info data Constant it
= Int info Text = Int Text
| Nat info Text | Nat Text
| String info Text | String Text
| Float info Text | Float Text
| Bytes info Text | Bytes Text
| Tez info Text | Tez Text
| WrongConstant Error deriving (Show) via PP (Constant it)
deriving (Show) via PP (Constant info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Pattern info data Pattern it
= IsConstr info (Name info) (Maybe (Pattern info)) = IsConstr it (Maybe it) -- (Name) (Maybe (Pattern))
| IsConstant info (Constant info) | IsConstant it -- (Constant)
| IsVar info (Name info) | IsVar it -- (Name)
| IsCons info (Pattern info) (Pattern info) | IsCons it it -- (Pattern) (Pattern)
| IsWildcard info | IsWildcard
| IsList info [Pattern info] | IsList [it] -- [Pattern]
| IsTuple info [Pattern info] | IsTuple [it] -- [Pattern]
| WrongPattern Error deriving (Show) via PP (Pattern it)
deriving (Show) via PP (Pattern info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data QualifiedName info data QualifiedName it
= QualifiedName = QualifiedName
{ qnInfo :: info { qnSource :: it -- Name
, qnSource :: Name info , qnPath :: [it] -- [Path]
, qnPath :: [Path info]
} }
| WrongQualifiedName Error deriving (Show) via PP (QualifiedName it)
deriving (Show) via PP (QualifiedName info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Path info data Path it
= At info (Name info) = At it -- (Name)
| Ix info Text | Ix Text
| WrongPath Error deriving (Show) via PP (Path it)
deriving (Show) via PP (Path info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Name info = Name data Name it = Name
{ _info :: info { _raw :: Text
, _raw :: Text
} }
| WrongName Error deriving (Show) via PP (Name it)
deriving (Show) via PP (Name info)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
c :: HasComments i => i -> Doc -> Doc instance Pretty1 Contract where
c i d = pp1 = \case
case getComments i of Contract decls ->
[] -> 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 $
sparseBlock decls sparseBlock decls
WrongContract err -> instance Pretty1 Declaration where
pp err 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 instance Pretty1 Binding where
pp = \case pp1 = \case
ValueDecl i binding -> c i $ pp binding Irrefutable pat expr -> error "irrefs in pascaligo?"
TypeDecl i n ty -> c i $ "type" <+> pp n <+> "=" `indent` pp ty Function isRec name params ty body ->
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 $
( (
( (
( (if isRec then "recursive" else empty) ( (if isRec then "recursive" else empty)
<+> "function" <+> "function"
<+> pp name <+> name
) )
`indent` tuple params `indent` tuple params
) )
`indent` (":" <+> pp ty <+> "is") `indent` (":" <+> ty <+> "is")
) )
`indent` pp body `indent` body
Var i name ty value -> c i $ "var" <+> pp name <+> ":" <+> pp ty <+> ":=" `indent` pp value Var name ty value -> "var" <+> name <+> ":" <+> ty <+> ":=" `indent` value
Const i name ty body -> c i $ "const" <+> pp name <+> ":" <+> pp ty <+> "=" `indent` pp body Const name ty body -> "const" <+> name <+> ":" <+> ty <+> "=" `indent` body
WrongBinding err ->
pp err
instance HasComments i => Pretty (VarDecl i) where instance Pretty1 VarDecl where
pp = \case pp1 = \case
Decl i mutability name ty -> c i $ Decl mutability name ty -> mutability <+> name <+> ":" `indent` ty
pp mutability <+> pp name <+> ":" `indent` pp ty
WrongVarDecl err ->
pp err
instance HasComments i => Pretty (Mutable i) where instance Pretty1 Mutable where
pp = \case pp1 = \case
Mutable i -> c i $ "var" Mutable -> "var"
Immutable i -> c i $ "const" Immutable -> "const"
WrongMutable err -> pp err
instance HasComments i => Pretty (Type i) where instance Pretty1 Type where
pp = \case pp1 = \case
TArrow i dom codom -> c i $ parens (pp dom `indent` "->" <+> pp codom) TArrow dom codom -> parens (dom `indent` "->" <+> codom)
TRecord i fields -> c i $ "record [" `indent` block fields `above` "]" TRecord fields -> "record [" `indent` block fields `above` "]"
TVar i name -> c i $ pp name TVar name -> name
TSum i variants -> c i $ block variants TSum variants -> block variants
TProduct i elements -> c i $ train " *" elements TProduct elements -> train " *" elements
TApply i f xs -> c i $ pp f <> tuple xs TApply f xs -> f <> tuple xs
WrongType err -> pp err
where where
ppField (name, ty) = pp name <> ": " <> pp ty <> ";" ppField (name, ty) = name <> ": " <> ty <> ";"
instance HasComments i => Pretty (Variant i) where instance Pretty1 Variant where
pp = \case pp1 = \case
Variant i ctor (Just ty) -> c i $ "|" <+> pp ctor <+> "of" `indent` pp ty Variant ctor (Just ty) -> "|" <+> ctor <+> "of" `indent` ty
Variant i ctor _ -> c i $ "|" <+> pp ctor Variant ctor _ -> "|" <+> ctor
WrongVariant err -> pp err
-- My eyes. instance Pretty1 Expr where
instance HasComments i => Pretty (Expr i) where pp1 = \case
pp = \case Let decls body -> "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` body
Let i decls body -> c i $ "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` pp body Apply f xs -> f <+> tuple xs
Apply i f xs -> c i $ pp f <+> tuple xs Constant constant -> constant
Constant i constant -> c i $ pp constant Ident qname -> qname
Ident i qname -> c i $ pp qname BinOp l o r -> parens (l <+> pp o <+> r)
BinOp i l o r -> c i $ parens (pp l <+> pp o <+> pp r) UnOp o r -> parens (pp o <+> r)
UnOp i o r -> c i $ parens (pp o <+> pp r) Record az -> "record" <+> list az
Record i az -> c i $ "record" <+> list az If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
If i b t e -> c i $ fsep ["if" `indent` pp b, "then" `indent` pp t, "else" `indent` pp e] Assign l r -> l <+> ":=" `indent` r
Assign i l r -> c i $ pp l <+> ":=" `indent` pp r List l -> "list" <+> list l
List i l -> c i $ "list" <+> list l Set l -> "set" <+> list l
Set i l -> c i $ "set" <+> list l Tuple l -> tuple l
Tuple i l -> c i $ tuple l Annot n t -> parens (n <+> ":" `indent` t)
Annot i n t -> c i $ parens (pp n <+> ":" `indent` pp t) Attrs ts -> "attributes" <+> list ts
Attrs i ts -> c i $ "attributes" <+> list ts BigMap bs -> "big_map" <+> list bs
BigMap i bs -> c i $ "big_map" <+> list bs Map bs -> "map" <+> list bs
Map i bs -> c i $ "map" <+> list bs MapRemove k m -> "remove" `indent` k `above` "from" <+> "map" `indent` m
MapRemove i k m -> c i $ "remove" `indent` pp k `above` "from" <+> "map" `indent` pp m SetRemove k s -> "remove" `indent` k `above` "from" <+> "set" `indent` s
SetRemove i k s -> c i $ "remove" `indent` pp k `above` "from" <+> "set" `indent` pp s Indexing a j -> a <> list [j]
Indexing i a j -> c i $ pp a <> list [j] Case s az -> "case" <+> s <+> "of" `indent` block az
Case i s az -> c i $ "case" <+> pp s <+> "of" `indent` block az Skip -> "skip"
Skip i -> c i $ "skip" ForLoop j s f b -> "for" <+> j <+> ":=" <+> s <+> "to" <+> f `indent` b
ForLoop i j s f b -> c i $ "for" <+> pp j <+> ":=" <+> pp s <+> "to" <+> pp f `indent` pp b ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
ForBox i k mv t z b -> c i $ "for" <+> pp k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> pp z `indent` pp b WhileLoop f b -> "while" <+> f `indent` b
WhileLoop i f b -> c i $ "while" <+> pp f `indent` pp b Seq es -> "block {" `indent` sparseBlock es `above` "}"
Seq i es -> c i $ "block {" `indent` sparseBlock es `above` "}" Lambda ps ty b -> (("function" `indent` tuple ps) `indent` (":" <+> ty)) `indent` b
Lambda i ps ty b -> c i $ (("function" `indent` tuple ps) `indent` (":" <+> pp ty)) `indent` pp b MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
MapPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "map" `indent` list bs SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs
SetPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "set" `indent` list bs RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up
RecordUpd i r up -> c i $ pp r `indent` "with" <+> "record" `indent` list up
WrongExpr err -> pp err
instance HasComments i => Pretty (Alt i) where instance Pretty1 Alt where
pp = \case pp1 = \case
Alt i p b -> c i $ "|" <+> pp p <+> "->" `indent` pp b Alt p b -> "|" <+> p <+> "->" `indent` b
WrongAlt err -> pp err
instance HasComments i => Pretty (MapBinding i) where instance Pretty1 MapBinding where
pp = \case pp1 = \case
MapBinding i k v -> c i $ pp k <+> "->" `indent` pp v MapBinding k v -> k <+> "->" `indent` v
WrongMapBinding err -> pp err
instance HasComments i => Pretty (Assignment i) where instance Pretty1 Assignment where
pp = \case pp1 = \case
Assignment i n e -> c i $ pp n <+> "=" `indent` pp e Assignment n e -> n <+> "=" `indent` e
WrongAssignment err -> pp err
instance HasComments i => Pretty (FieldAssignment i) where instance Pretty1 FieldAssignment where
pp = \case pp1 = \case
FieldAssignment i n e -> c i $ pp n <+> "=" `indent` pp e FieldAssignment n e -> n <+> "=" `indent` e
WrongFieldAssignment err -> pp err
instance HasComments i => Pretty (Constant i) where instance Pretty1 Constant where
pp = \case pp1 = \case
Int i z -> c i $ pp z Int z -> pp z
Nat i z -> c i $ pp z Nat z -> pp z
String i z -> c i $ pp z String z -> pp z
Float i z -> c i $ pp z Float z -> pp z
Bytes i z -> c i $ pp z Bytes z -> pp z
Tez i z -> c i $ pp z Tez z -> pp z
WrongConstant err -> pp err
instance HasComments i => Pretty (QualifiedName i) where instance Pretty1 QualifiedName where
pp = \case pp1 = \case
QualifiedName i src path -> c i $ pp src <> sepByDot path QualifiedName src path -> src <> sepByDot path
WrongQualifiedName err -> pp err
instance HasComments i => Pretty (Pattern i) where instance Pretty1 Pattern where
pp = \case pp1 = \case
IsConstr i ctor arg -> c i $ pp ctor <+> maybe empty pp arg IsConstr ctor arg -> ctor <+> maybe empty id arg
IsConstant i z -> c i $ pp z IsConstant z -> z
IsVar i name -> c i $ pp name IsVar name -> name
IsCons i h t -> c i $ pp h <+> ("#" <+> pp t) IsCons h t -> h <+> ("#" <+> t)
IsWildcard i -> c i $ "_" IsWildcard -> "_"
IsList i l -> c i $ list l IsList l -> list l
IsTuple i t -> c i $ tuple t IsTuple t -> tuple t
WrongPattern err -> pp err
instance HasComments i => Pretty (Name i) where instance Pretty1 Name where
pp = \case pp1 = \case
Name i raw -> c i $ pp raw Name raw -> pp raw
WrongName err -> pp err
instance HasComments i => Pretty (Path i) where instance Pretty1 Path where
pp = \case pp1 = \case
At i n -> c i $ pp n At n -> n
Ix i j -> c i $ pp j Ix j -> pp j
WrongPath err -> pp err
instance HasComments i => Pretty (TField i) where instance Pretty1 TField where
pp = \case pp1 = \case
TField i n t -> c i $ pp n <> ":" `indent` pp t TField n t -> n <> ":" `indent` t
WrongTField err -> pp err
instance HasComments i => Pretty (LHS i) where instance Pretty1 LHS where
pp = \case pp1 = \case
LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi LHS qn mi -> qn <> foldMap brackets mi
WrongLHS err -> pp err
foldMap makePrisms type Pascal = Tree
[ ''Name [ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
, ''Path , MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
, ''QualifiedName , Declaration, Contract
, ''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

20
tools/lsp/squirrel/src/Error.hs Normal file
View File

@ -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 <> "▓"

23
tools/lsp/squirrel/src/HasComments.hs Normal file
View File

@ -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 () = []

6
tools/lsp/squirrel/src/HasErrors.hs Normal file
View File

@ -0,0 +1,6 @@
module HasErrors where
import Error
class HasErrors h where
errors :: h -> [Error]

11
tools/lsp/squirrel/src/Lattice.hs Normal file
View File

@ -0,0 +1,11 @@
module Lattice where
class Lattice l where
(?>) :: l -> l -> Bool
(<?) :: l -> l -> Bool
(?>) = flip (<?)
(<?) = flip (?>)
{-# minimal (?>) | (<?) #-}

59
tools/lsp/squirrel/src/Parser.hs
View File

@ -44,8 +44,8 @@ module Parser
, subtree , subtree
, anything , anything
, token , token
, ASTInfo , ASTInfo(..)
, ctor , getInfo
, inside , inside
, many , many
, some , some
@ -56,7 +56,6 @@ module Parser
, stubbed , stubbed
, Stubbed (..) , Stubbed (..)
, Error (..) , Error (..)
, HasComments (getComments)
) where ) where
import Control.Lens hiding (inside) import Control.Lens hiding (inside)
@ -78,21 +77,12 @@ import Data.ByteString (ByteString)
import ParseTree import ParseTree
import Range import Range
import Pretty import Pretty
import HasComments
import Error
import Stubbed
import Debug.Trace import Debug.Trace
-- | 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 <> "▓"
-- | Parser of tree-sitter-made tree. -- | Parser of tree-sitter-made tree.
-- --
-- TODO: separate state. Polysemy? -- TODO: separate state. Polysemy?
@ -117,13 +107,13 @@ newtype Parser a = Parser
-- | Generate error originating at current location. -- | Generate error originating at current location.
makeError :: Text -> Parser Error makeError :: Text -> Parser Error
makeError msg = do makeError msg = do
rng <- getRange rng <- currentRange
makeError' msg rng makeError' msg rng
-- | Generate error originating at given location. -- | Generate error originating at given location.
makeError' :: Text -> Range -> Parser Error makeError' :: Text -> Range -> Parser Error
makeError' msg rng = do makeError' msg rng = do
rng <- getRange rng <- currentRange
src <- gets (pfGrove . fst) <&> \case src <- gets (pfGrove . fst) <&> \case
[] -> "" [] -> ""
(,) _ ParseTree { ptSource } : _ -> ptSource (,) _ ParseTree { ptSource } : _ -> ptSource
@ -343,8 +333,8 @@ range parser =
return (a, pfRange) return (a, pfRange)
-- | Get current range. -- | Get current range.
getRange :: Parser Range currentRange :: Parser Range
getRange = snd <$> range (return ()) currentRange = snd <$> range (return ())
-- | Remove all keys until given key is found; remove the latter as well. -- | Remove all keys until given key is found; remove the latter as well.
-- --
@ -392,26 +382,7 @@ notFollowedBy parser = do
die "notFollowedBy" die "notFollowedBy"
stub :: Stubbed a => Error -> a stub :: Stubbed a => Error -> a
stub = (stubbing #) 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
-- | Universal accessor. -- | Universal accessor.
-- --
@ -447,15 +418,15 @@ data ASTInfo = ASTInfo
, aiComments :: [Text] , aiComments :: [Text]
} }
class HasComments c where
getComments :: c -> [Text]
instance HasComments ASTInfo where instance HasComments ASTInfo where
getComments = aiComments getComments = aiComments
instance HasRange ASTInfo where
getRange = aiRange
-- | Equip given constructor with info. -- | Equip given constructor with info.
ctor :: (ASTInfo -> a) -> Parser a getInfo :: Parser ASTInfo
ctor = (<$> (ASTInfo <$> getRange <*> grabComments)) getInfo = ASTInfo <$> currentRange <*> grabComments
grabComments :: Parser [Text] grabComments :: Parser [Text]
grabComments = do grabComments = do

15
tools/lsp/squirrel/src/Pretty.hs
View File

@ -9,10 +9,13 @@ module Pretty
where where
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text, pack)
import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint hiding ((<>))
ppToText :: Pretty a => a -> Text
ppToText = pack . show . pp
-- | With this, one can `data X = ...; derive Show via PP X` -- | With this, one can `data X = ...; derive Show via PP X`
newtype PP a = PP { unPP :: a } newtype PP a = PP { unPP :: a }
@ -23,10 +26,20 @@ instance Pretty a => Show (PP a) where
class Pretty p where class Pretty p where
pp :: p -> Doc 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. -- | Common instance.
instance Pretty Text where instance Pretty Text where
pp = text . Text.unpack pp = text . Text.unpack
-- | Common instance.
instance Pretty Doc where
pp = id
tuple :: Pretty p => [p] -> Doc tuple :: Pretty p => [p] -> Doc
tuple = parens . train "," tuple = parens . train ","

2
tools/lsp/squirrel/src/Range.hs
View File

@ -22,4 +22,4 @@ instance Pretty Range where
int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc
class HasRange a where class HasRange a where
location :: Lens' a Range getRange :: a -> Range

28
tools/lsp/squirrel/src/Stubbed.hs Normal file
View File

@ -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

105
tools/lsp/squirrel/src/Tree.hs Normal file
View File

@ -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 <? info', info, info') $
if info <? info'
then Tree tree : foldMap go fres
else []
go _ = []
-- | Update the tree in the monad that exports its methods.
updateTree
:: ( UpdateOver m (Union fs) (Tree fs a)
, Traversable (Union fs)
)
=> (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

77
tools/lsp/squirrel/src/Union.hs Normal file
View File

@ -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

22
tools/lsp/squirrel/src/Update.hs Normal file
View File

@ -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 ()