Convert to monotyped AST
This commit is contained in:
Kirill Andreev
parent
113a2425a4
commit
d380e46737
@ -27,6 +27,7 @@ import ParseTree
|
||||
import Parser
|
||||
import Range
|
||||
import AST
|
||||
import HasErrors
|
||||
import Pretty
|
||||
|
||||
main :: IO ()
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -15,64 +15,84 @@ 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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
ranged do
|
||||
pure Function
|
||||
<*> recursive
|
||||
<*> inside "name:" name
|
||||
<*> inside "parameters:parameters" do
|
||||
@ -88,12 +108,14 @@ 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
|
||||
ranged do
|
||||
pure Ident <*> do
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> name
|
||||
<*> pure []
|
||||
, opCall
|
||||
@ -133,48 +155,56 @@ 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
|
||||
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
|
||||
ranged do
|
||||
pure SetPatch
|
||||
<*> inside "container:path" (qname <|> projection)
|
||||
<*> many do inside "key" expr
|
||||
|
||||
record_update = do
|
||||
subtree "update_record" do
|
||||
ctor RecordUpd
|
||||
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
|
||||
ranged do
|
||||
pure FieldAssignment
|
||||
<*> inside "lhs:path" do qname <|> projection
|
||||
<*> inside "_rhs" expr
|
||||
|
||||
map_patch = do
|
||||
subtree "map_patch" do
|
||||
ctor MapPatch
|
||||
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
|
||||
ranged do
|
||||
pure List <*> many do
|
||||
inside "element" expr
|
||||
|
||||
lambda_expr = do
|
||||
subtree "fun_expr" do
|
||||
ctor Lambda
|
||||
ranged do
|
||||
pure Lambda
|
||||
<*> inside "parameters:parameters" do
|
||||
many do inside "parameter" paramDecl
|
||||
<*> inside "type" newtype_
|
||||
@ -182,7 +212,8 @@ lambda_expr = do
|
||||
|
||||
seq_expr = do
|
||||
subtree "block" do
|
||||
ctor Seq <*> many do
|
||||
ranged do
|
||||
pure Seq <*> many do
|
||||
inside "statement" do
|
||||
declaration <|> statement
|
||||
|
||||
@ -192,7 +223,8 @@ loop = do
|
||||
|
||||
for_container = do
|
||||
subtree "for_loop" do
|
||||
ctor ForBox
|
||||
ranged do
|
||||
pure ForBox
|
||||
<*> inside "key" name
|
||||
<*> optional do inside "value" name
|
||||
<*> inside "kind" anything
|
||||
@ -201,13 +233,15 @@ for_container = do
|
||||
|
||||
while_loop = do
|
||||
subtree "while_loop" do
|
||||
ctor WhileLoop
|
||||
ranged do
|
||||
pure WhileLoop
|
||||
<*> inside "breaker" expr
|
||||
<*> inside "body" expr
|
||||
|
||||
for_loop = do
|
||||
subtree "for_loop" do
|
||||
ctor ForLoop
|
||||
ranged do
|
||||
pure ForLoop
|
||||
<*> inside "name" name
|
||||
<*> inside "begin" expr
|
||||
<*> inside "end" expr
|
||||
@ -216,57 +250,66 @@ for_loop = do
|
||||
clause_block = do
|
||||
subtree "clause_block" do
|
||||
inside "block:block" do
|
||||
ctor Seq <*> many do
|
||||
ranged do
|
||||
pure Seq <*> many do
|
||||
inside "statement" (declaration <|> statement)
|
||||
<|> do
|
||||
subtree "clause_block" do
|
||||
ctor Seq <*> many do
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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,63 +320,84 @@ 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"
|
||||
ranged do
|
||||
pure IsConstr
|
||||
<*> inside "constr" do
|
||||
ranged do
|
||||
pure Name <*> token "Some"
|
||||
|
||||
<*> do Just <$> inside "arg" pattern
|
||||
|
||||
string_pattern :: Parser (Pattern ASTInfo)
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
ranged do
|
||||
pure Ident <*> do
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> ranged do
|
||||
pure Name <*> do
|
||||
true <|> false <|> none <|> unit
|
||||
<*> pure []
|
||||
|
||||
true = token "True"
|
||||
@ -341,286 +405,340 @@ 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'
|
||||
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
|
||||
ranged do
|
||||
pure Apply
|
||||
<*> inside "constr:constr" do
|
||||
ctor Ident <*> do
|
||||
ctor QualifiedName
|
||||
ranged do
|
||||
pure Ident <*> do
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> capitalName
|
||||
<*> pure []
|
||||
<*> inside "arguments:arguments" do
|
||||
many do inside "argument" expr
|
||||
many do
|
||||
inside "argument" expr
|
||||
|
||||
indexing :: Parser (Expr ASTInfo)
|
||||
indexing :: Parser (Pascal ASTInfo)
|
||||
indexing = do
|
||||
subtree "map_lookup" do
|
||||
ctor Indexing
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
ranged do
|
||||
pure Ident <*> do
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> 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
|
||||
subtree "tuple_expr" do
|
||||
ctor Tuple <*> many do
|
||||
ranged do
|
||||
pure Tuple <*> many do
|
||||
inside "element" expr
|
||||
|
||||
attributes :: Parser (Expr ASTInfo)
|
||||
attributes :: Parser (Pascal ASTInfo)
|
||||
attributes = do
|
||||
subtree "attr_decl" do
|
||||
ctor Attrs <*> many do
|
||||
ranged do
|
||||
pure Attrs <*> many do
|
||||
inside "attribute" do
|
||||
token "String"
|
||||
|
||||
string_literal :: Parser (Expr ASTInfo)
|
||||
string_literal :: Parser (Pascal ASTInfo)
|
||||
string_literal = do
|
||||
ctor Constant <*> do
|
||||
ctor String <*>
|
||||
ranged do
|
||||
pure Constant <*> do
|
||||
ranged do
|
||||
pure String <*> do
|
||||
token "String"
|
||||
|
||||
has_type :: Parser (Expr ASTInfo)
|
||||
has_type :: Parser (Pascal ASTInfo)
|
||||
has_type = do
|
||||
subtree "annot_expr" do
|
||||
ctor Annot
|
||||
ranged do
|
||||
pure Annot
|
||||
<*> inside "subject" expr
|
||||
<*> inside "type" type_
|
||||
|
||||
list_expr :: Parser (Expr ASTInfo)
|
||||
list_expr :: Parser (Pascal ASTInfo)
|
||||
list_expr = do
|
||||
subtree "list_expr" do
|
||||
ctor List <*> many do
|
||||
ranged do
|
||||
pure List <*> many do
|
||||
inside "element" expr
|
||||
|
||||
qname :: Parser (QualifiedName ASTInfo)
|
||||
qname :: Parser (Pascal ASTInfo)
|
||||
qname = do
|
||||
ctor QualifiedName
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> name
|
||||
<*> pure []
|
||||
|
||||
qname' :: Parser (QualifiedName ASTInfo)
|
||||
qname' :: Parser (Pascal ASTInfo)
|
||||
qname' = do
|
||||
ctor QualifiedName
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> name'
|
||||
<*> pure []
|
||||
|
||||
assign :: Parser (Expr ASTInfo)
|
||||
assign :: Parser (Pascal ASTInfo)
|
||||
assign = do
|
||||
subtree "assignment" do
|
||||
ctor Assign
|
||||
ranged do
|
||||
pure Assign
|
||||
<*> inside "LHS" lhs
|
||||
<*> inside "RHS" expr
|
||||
|
||||
lhs :: Parser (LHS ASTInfo)
|
||||
lhs :: Parser (Pascal ASTInfo)
|
||||
lhs =
|
||||
do ctor LHS
|
||||
ranged do
|
||||
pure LHS
|
||||
<*> inside "container:path" do
|
||||
qname <|> projection
|
||||
<*> pure Nothing
|
||||
<|>
|
||||
do ctor LHS
|
||||
ranged do
|
||||
pure LHS
|
||||
<*> subtree "path" do
|
||||
qname <|> projection
|
||||
<*> pure Nothing
|
||||
<|>
|
||||
do subtree "map_lookup" do
|
||||
ctor LHS
|
||||
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
|
||||
ranged do
|
||||
pure If
|
||||
<*> inside "selector" expr
|
||||
<*> inside "then:if_clause" expr
|
||||
<*> inside "else:if_clause" expr
|
||||
<|> do
|
||||
subtree "cond_expr" do
|
||||
ctor If
|
||||
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'
|
||||
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
|
||||
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
|
||||
ranged do
|
||||
pure Record <*> many do
|
||||
inside "assignment:field_assignment" do
|
||||
ctor Assignment
|
||||
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
|
||||
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
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> 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
|
||||
subtree "op_expr"
|
||||
$ do inside "the" expr
|
||||
<|> do ctor BinOp
|
||||
<|> ranged do
|
||||
pure BinOp
|
||||
<*> inside "arg1" expr
|
||||
<*> inside "op" anything
|
||||
<*> inside "arg2" expr
|
||||
<|> do ctor UnOp
|
||||
<|> 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
|
||||
ranged do
|
||||
pure Decl
|
||||
<*> inside "access" do
|
||||
ctor access' <*> anything
|
||||
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
|
||||
ranged do
|
||||
pure TSum <*> many do
|
||||
inside "variant" variant
|
||||
|
||||
variant = do
|
||||
subtree "variant" do
|
||||
ctor Variant
|
||||
ranged do
|
||||
pure Variant
|
||||
<*> inside "constructor:constr" capitalName
|
||||
<*> optional do inside "arguments" type_
|
||||
|
||||
record_type = do
|
||||
subtree "record_type" do
|
||||
ctor TRecord <*> many do
|
||||
ranged do
|
||||
pure TRecord <*> many do
|
||||
inside "field" do
|
||||
field_decl
|
||||
|
||||
field_decl = do
|
||||
subtree "field_decl" do
|
||||
ctor TField
|
||||
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
|
||||
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
|
||||
ranged do
|
||||
pure TApply
|
||||
<*> inside "typeConstr" name'
|
||||
<*> inside "arguments" typeTuple
|
||||
, subtree "invokeUnary" do
|
||||
ctor TApply
|
||||
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_
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
<+> name
|
||||
)
|
||||
`indent` tuple params
|
||||
)
|
||||
`indent` (":" <+> pp ty <+> "is")
|
||||
`indent` (":" <+> ty <+> "is")
|
||||
)
|
||||
`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` 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
|
||||
|
||||
20
tools/lsp/squirrel/src/Error.hs
Normal file
20
tools/lsp/squirrel/src/Error.hs
Normal 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
23
tools/lsp/squirrel/src/HasComments.hs
Normal 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
6
tools/lsp/squirrel/src/HasErrors.hs
Normal 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
11
tools/lsp/squirrel/src/Lattice.hs
Normal file
@ -0,0 +1,11 @@
|
||||
|
||||
module Lattice where
|
||||
|
||||
class Lattice l where
|
||||
(?>) :: l -> l -> Bool
|
||||
(<?) :: l -> l -> Bool
|
||||
|
||||
(?>) = flip (<?)
|
||||
(<?) = flip (?>)
|
||||
|
||||
{-# minimal (?>) | (<?) #-}
|
||||
@ -44,8 +44,8 @@ module Parser
|
||||
, subtree
|
||||
, anything
|
||||
, token
|
||||
, ASTInfo
|
||||
, ctor
|
||||
, ASTInfo(..)
|
||||
, getInfo
|
||||
, inside
|
||||
, many
|
||||
, some
|
||||
@ -56,7 +56,6 @@ module Parser
|
||||
, stubbed
|
||||
, Stubbed (..)
|
||||
, Error (..)
|
||||
, HasComments (getComments)
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (inside)
|
||||
@ -78,21 +77,12 @@ import Data.ByteString (ByteString)
|
||||
import ParseTree
|
||||
import Range
|
||||
import Pretty
|
||||
import HasComments
|
||||
import Error
|
||||
import Stubbed
|
||||
|
||||
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.
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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 ","
|
||||
|
||||
|
||||
@ -22,4 +22,4 @@ instance Pretty Range where
|
||||
int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc
|
||||
|
||||
class HasRange a where
|
||||
location :: Lens' a Range
|
||||
getRange :: a -> Range
|
||||
28
tools/lsp/squirrel/src/Stubbed.hs
Normal file
28
tools/lsp/squirrel/src/Stubbed.hs
Normal 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
105
tools/lsp/squirrel/src/Tree.hs
Normal 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
77
tools/lsp/squirrel/src/Union.hs
Normal 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
22
tools/lsp/squirrel/src/Update.hs
Normal 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 ()
|
||||
Loading…
Reference in New Issue
Block a user