Convert to monotyped AST
This commit is contained in:
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
|
File diff suppressed because it is too large
Load Diff
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
|
||||
)
|
||||
`indent` tuple params
|
||||
( (if isRec then "recursive" else empty)
|
||||
<+> "function"
|
||||
<+> name
|
||||
)
|
||||
`indent` (":" <+> pp ty <+> "is")
|
||||
`indent` tuple params
|
||||
)
|
||||
`indent` pp body
|
||||
Var i name ty value -> c i $ "var" <+> pp name <+> ":" <+> pp ty <+> ":=" `indent` pp value
|
||||
Const i name ty body -> c i $ "const" <+> pp name <+> ":" <+> pp ty <+> "=" `indent` pp body
|
||||
WrongBinding err ->
|
||||
pp err
|
||||
`indent` (":" <+> ty <+> "is")
|
||||
)
|
||||
`indent` body
|
||||
Var name ty value -> "var" <+> name <+> ":" <+> ty <+> ":=" `indent` value
|
||||
Const name ty body -> "const" <+> name <+> ":" <+> ty <+> "=" `indent` body
|
||||
|
||||
instance HasComments i => Pretty (VarDecl i) where
|
||||
pp = \case
|
||||
Decl i mutability name ty -> c i $
|
||||
pp mutability <+> pp name <+> ":" `indent` pp ty
|
||||
WrongVarDecl err ->
|
||||
pp err
|
||||
instance Pretty1 VarDecl where
|
||||
pp1 = \case
|
||||
Decl mutability name ty -> mutability <+> name <+> ":" `indent` ty
|
||||
|
||||
instance HasComments i => Pretty (Mutable i) where
|
||||
pp = \case
|
||||
Mutable i -> c i $ "var"
|
||||
Immutable i -> c i $ "const"
|
||||
WrongMutable err -> pp err
|
||||
instance Pretty1 Mutable where
|
||||
pp1 = \case
|
||||
Mutable -> "var"
|
||||
Immutable -> "const"
|
||||
|
||||
instance HasComments i => Pretty (Type i) where
|
||||
pp = \case
|
||||
TArrow i dom codom -> c i $ parens (pp dom `indent` "->" <+> pp codom)
|
||||
TRecord i fields -> c i $ "record [" `indent` block fields `above` "]"
|
||||
TVar i name -> c i $ pp name
|
||||
TSum i variants -> c i $ block variants
|
||||
TProduct i elements -> c i $ train " *" elements
|
||||
TApply i f xs -> c i $ pp f <> tuple xs
|
||||
WrongType err -> pp err
|
||||
instance Pretty1 Type where
|
||||
pp1 = \case
|
||||
TArrow dom codom -> parens (dom `indent` "->" <+> codom)
|
||||
TRecord fields -> "record [" `indent` block fields `above` "]"
|
||||
TVar name -> name
|
||||
TSum variants -> block variants
|
||||
TProduct elements -> train " *" elements
|
||||
TApply f xs -> f <> tuple xs
|
||||
where
|
||||
ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
|
||||
ppField (name, ty) = name <> ": " <> ty <> ";"
|
||||
|
||||
instance HasComments i => Pretty (Variant i) where
|
||||
pp = \case
|
||||
Variant i ctor (Just ty) -> c i $ "|" <+> pp ctor <+> "of" `indent` pp ty
|
||||
Variant i ctor _ -> c i $ "|" <+> pp ctor
|
||||
WrongVariant err -> pp err
|
||||
instance Pretty1 Variant where
|
||||
pp1 = \case
|
||||
Variant ctor (Just ty) -> "|" <+> ctor <+> "of" `indent` ty
|
||||
Variant ctor _ -> "|" <+> ctor
|
||||
|
||||
-- My eyes.
|
||||
instance HasComments i => Pretty (Expr i) where
|
||||
pp = \case
|
||||
Let i decls body -> c i $ "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` pp body
|
||||
Apply i f xs -> c i $ pp f <+> tuple xs
|
||||
Constant i constant -> c i $ pp constant
|
||||
Ident i qname -> c i $ pp qname
|
||||
BinOp i l o r -> c i $ parens (pp l <+> pp o <+> pp r)
|
||||
UnOp i o r -> c i $ parens (pp o <+> pp r)
|
||||
Record i az -> c i $ "record" <+> list az
|
||||
If i b t e -> c i $ fsep ["if" `indent` pp b, "then" `indent` pp t, "else" `indent` pp e]
|
||||
Assign i l r -> c i $ pp l <+> ":=" `indent` pp r
|
||||
List i l -> c i $ "list" <+> list l
|
||||
Set i l -> c i $ "set" <+> list l
|
||||
Tuple i l -> c i $ tuple l
|
||||
Annot i n t -> c i $ parens (pp n <+> ":" `indent` pp t)
|
||||
Attrs i ts -> c i $ "attributes" <+> list ts
|
||||
BigMap i bs -> c i $ "big_map" <+> list bs
|
||||
Map i bs -> c i $ "map" <+> list bs
|
||||
MapRemove i k m -> c i $ "remove" `indent` pp k `above` "from" <+> "map" `indent` pp m
|
||||
SetRemove i k s -> c i $ "remove" `indent` pp k `above` "from" <+> "set" `indent` pp s
|
||||
Indexing i a j -> c i $ pp a <> list [j]
|
||||
Case i s az -> c i $ "case" <+> pp s <+> "of" `indent` block az
|
||||
Skip i -> c i $ "skip"
|
||||
ForLoop i j s f b -> c i $ "for" <+> pp j <+> ":=" <+> pp s <+> "to" <+> pp f `indent` pp b
|
||||
ForBox i k mv t z b -> c i $ "for" <+> pp k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> pp z `indent` pp b
|
||||
WhileLoop i f b -> c i $ "while" <+> pp f `indent` pp b
|
||||
Seq i es -> c i $ "block {" `indent` sparseBlock es `above` "}"
|
||||
Lambda i ps ty b -> c i $ (("function" `indent` tuple ps) `indent` (":" <+> pp ty)) `indent` pp b
|
||||
MapPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "map" `indent` list bs
|
||||
SetPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "set" `indent` list bs
|
||||
RecordUpd i r up -> c i $ pp r `indent` "with" <+> "record" `indent` list up
|
||||
WrongExpr err -> pp err
|
||||
instance Pretty1 Expr where
|
||||
pp1 = \case
|
||||
Let decls body -> "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` body
|
||||
Apply f xs -> f <+> tuple xs
|
||||
Constant constant -> constant
|
||||
Ident qname -> qname
|
||||
BinOp l o r -> parens (l <+> pp o <+> r)
|
||||
UnOp o r -> parens (pp o <+> r)
|
||||
Record az -> "record" <+> list az
|
||||
If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
|
||||
Assign l r -> l <+> ":=" `indent` r
|
||||
List l -> "list" <+> list l
|
||||
Set l -> "set" <+> list l
|
||||
Tuple l -> tuple l
|
||||
Annot n t -> parens (n <+> ":" `indent` t)
|
||||
Attrs ts -> "attributes" <+> list ts
|
||||
BigMap bs -> "big_map" <+> list bs
|
||||
Map bs -> "map" <+> list bs
|
||||
MapRemove k m -> "remove" `indent` k `above` "from" <+> "map" `indent` m
|
||||
SetRemove k s -> "remove" `indent` k `above` "from" <+> "set" `indent` s
|
||||
Indexing a j -> a <> list [j]
|
||||
Case s az -> "case" <+> s <+> "of" `indent` block az
|
||||
Skip -> "skip"
|
||||
ForLoop j s f b -> "for" <+> j <+> ":=" <+> s <+> "to" <+> f `indent` b
|
||||
ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
|
||||
WhileLoop f b -> "while" <+> f `indent` b
|
||||
Seq es -> "block {" `indent` sparseBlock es `above` "}"
|
||||
Lambda ps ty b -> (("function" `indent` tuple ps) `indent` (":" <+> ty)) `indent` b
|
||||
MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
|
||||
SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs
|
||||
RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up
|
||||
|
||||
instance HasComments i => Pretty (Alt i) where
|
||||
pp = \case
|
||||
Alt i p b -> c i $ "|" <+> pp p <+> "->" `indent` pp b
|
||||
WrongAlt err -> pp err
|
||||
instance Pretty1 Alt where
|
||||
pp1 = \case
|
||||
Alt p b -> "|" <+> p <+> "->" `indent` b
|
||||
|
||||
instance HasComments i => Pretty (MapBinding i) where
|
||||
pp = \case
|
||||
MapBinding i k v -> c i $ pp k <+> "->" `indent` pp v
|
||||
WrongMapBinding err -> pp err
|
||||
instance Pretty1 MapBinding where
|
||||
pp1 = \case
|
||||
MapBinding k v -> k <+> "->" `indent` v
|
||||
|
||||
instance HasComments i => Pretty (Assignment i) where
|
||||
pp = \case
|
||||
Assignment i n e -> c i $ pp n <+> "=" `indent` pp e
|
||||
WrongAssignment err -> pp err
|
||||
instance Pretty1 Assignment where
|
||||
pp1 = \case
|
||||
Assignment n e -> n <+> "=" `indent` e
|
||||
|
||||
instance HasComments i => Pretty (FieldAssignment i) where
|
||||
pp = \case
|
||||
FieldAssignment i n e -> c i $ pp n <+> "=" `indent` pp e
|
||||
WrongFieldAssignment err -> pp err
|
||||
instance Pretty1 FieldAssignment where
|
||||
pp1 = \case
|
||||
FieldAssignment n e -> n <+> "=" `indent` e
|
||||
|
||||
instance HasComments i => Pretty (Constant i) where
|
||||
pp = \case
|
||||
Int i z -> c i $ pp z
|
||||
Nat i z -> c i $ pp z
|
||||
String i z -> c i $ pp z
|
||||
Float i z -> c i $ pp z
|
||||
Bytes i z -> c i $ pp z
|
||||
Tez i z -> c i $ pp z
|
||||
WrongConstant err -> pp err
|
||||
instance Pretty1 Constant where
|
||||
pp1 = \case
|
||||
Int z -> pp z
|
||||
Nat z -> pp z
|
||||
String z -> pp z
|
||||
Float z -> pp z
|
||||
Bytes z -> pp z
|
||||
Tez z -> pp z
|
||||
|
||||
instance HasComments i => Pretty (QualifiedName i) where
|
||||
pp = \case
|
||||
QualifiedName i src path -> c i $ pp src <> sepByDot path
|
||||
WrongQualifiedName err -> pp err
|
||||
instance Pretty1 QualifiedName where
|
||||
pp1 = \case
|
||||
QualifiedName src path -> src <> sepByDot path
|
||||
|
||||
instance HasComments i => Pretty (Pattern i) where
|
||||
pp = \case
|
||||
IsConstr i ctor arg -> c i $ pp ctor <+> maybe empty pp arg
|
||||
IsConstant i z -> c i $ pp z
|
||||
IsVar i name -> c i $ pp name
|
||||
IsCons i h t -> c i $ pp h <+> ("#" <+> pp t)
|
||||
IsWildcard i -> c i $ "_"
|
||||
IsList i l -> c i $ list l
|
||||
IsTuple i t -> c i $ tuple t
|
||||
WrongPattern err -> pp err
|
||||
instance Pretty1 Pattern where
|
||||
pp1 = \case
|
||||
IsConstr ctor arg -> ctor <+> maybe empty id arg
|
||||
IsConstant z -> z
|
||||
IsVar name -> name
|
||||
IsCons h t -> h <+> ("#" <+> t)
|
||||
IsWildcard -> "_"
|
||||
IsList l -> list l
|
||||
IsTuple t -> tuple t
|
||||
|
||||
|
||||
instance HasComments i => Pretty (Name i) where
|
||||
pp = \case
|
||||
Name i raw -> c i $ pp raw
|
||||
WrongName err -> pp err
|
||||
instance Pretty1 Name where
|
||||
pp1 = \case
|
||||
Name raw -> pp raw
|
||||
|
||||
instance HasComments i => Pretty (Path i) where
|
||||
pp = \case
|
||||
At i n -> c i $ pp n
|
||||
Ix i j -> c i $ pp j
|
||||
WrongPath err -> pp err
|
||||
instance Pretty1 Path where
|
||||
pp1 = \case
|
||||
At n -> n
|
||||
Ix j -> pp j
|
||||
|
||||
instance HasComments i => Pretty (TField i) where
|
||||
pp = \case
|
||||
TField i n t -> c i $ pp n <> ":" `indent` pp t
|
||||
WrongTField err -> pp err
|
||||
instance Pretty1 TField where
|
||||
pp1 = \case
|
||||
TField n t -> n <> ":" `indent` t
|
||||
|
||||
instance HasComments i => Pretty (LHS i) where
|
||||
pp = \case
|
||||
LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi
|
||||
WrongLHS err -> pp err
|
||||
instance Pretty1 LHS where
|
||||
pp1 = \case
|
||||
LHS qn mi -> qn <> foldMap brackets mi
|
||||
|
||||
foldMap makePrisms
|
||||
[ ''Name
|
||||
, ''Path
|
||||
, ''QualifiedName
|
||||
, ''Pattern
|
||||
, ''Constant
|
||||
, ''FieldAssignment
|
||||
, ''Assignment
|
||||
, ''MapBinding
|
||||
, ''LHS
|
||||
, ''Alt
|
||||
, ''Expr
|
||||
, ''TField
|
||||
, ''Variant
|
||||
, ''Type
|
||||
, ''Mutable
|
||||
, ''VarDecl
|
||||
, ''Binding
|
||||
, ''Declaration
|
||||
, ''Contract
|
||||
type Pascal = Tree
|
||||
[ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
|
||||
, MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
|
||||
, Declaration, Contract
|
||||
]
|
||||
|
||||
foldMap makeLenses
|
||||
[ ''Name
|
||||
]
|
||||
|
||||
instance Stubbed (Name info) where stubbing = _WrongName
|
||||
instance Stubbed (Path info) where stubbing = _WrongPath
|
||||
instance Stubbed (QualifiedName info) where stubbing = _WrongQualifiedName
|
||||
instance Stubbed (Pattern info) where stubbing = _WrongPattern
|
||||
instance Stubbed (Constant info) where stubbing = _WrongConstant
|
||||
instance Stubbed (FieldAssignment info) where stubbing = _WrongFieldAssignment
|
||||
instance Stubbed (Assignment info) where stubbing = _WrongAssignment
|
||||
instance Stubbed (MapBinding info) where stubbing = _WrongMapBinding
|
||||
instance Stubbed (LHS info) where stubbing = _WrongLHS
|
||||
instance Stubbed (Alt info) where stubbing = _WrongAlt
|
||||
instance Stubbed (Expr info) where stubbing = _WrongExpr
|
||||
instance Stubbed (TField info) where stubbing = _WrongTField
|
||||
instance Stubbed (Variant info) where stubbing = _WrongVariant
|
||||
instance Stubbed (Type info) where stubbing = _WrongType
|
||||
instance Stubbed (Mutable info) where stubbing = _WrongMutable
|
||||
instance Stubbed (VarDecl info) where stubbing = _WrongVarDecl
|
||||
instance Stubbed (Binding info) where stubbing = _WrongBinding
|
||||
instance Stubbed (Declaration info) where stubbing = _WrongDecl
|
||||
instance Stubbed (Contract info) where stubbing = _WrongContract
|
||||
|
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