Convert to monotyped AST

This commit is contained in:
Kirill Andreev 2020-06-01 18:17:33 +04:00
parent 113a2425a4
commit d380e46737
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
19 changed files with 1334 additions and 1773 deletions

View File

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

View File

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

View File

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

View File

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

View File

@ -1,292 +0,0 @@
{-
The AST and auxillary types along with their pretty-printers.
TODO: Untangle pretty-printing mess into combinators.
TODO: Store offending text verbatim in Wrong*.
-}
module AST.Errors where
import Parser
import AST.Types
class HasErrors h where
errors :: h -> [Error]
instance {-# OVERLAPPABLE #-} (HasErrors a, Foldable f) => HasErrors (f a) where
errors = foldMap errors
instance HasErrors (Contract i) where
errors = \case
Contract _ ds -> errors ds
WrongContract err -> return err
-- data Contract info
-- = Contract info [Declaration info]
-- | WrongContract Error
instance HasErrors (Declaration i) where
errors = \case
ValueDecl _ bind -> errors bind
TypeDecl _ n ty -> errors n <> errors ty
Action _ e -> errors e
Include _ _ -> fail "text"
WrongDecl err -> return err
-- data Declaration info
-- = ValueDecl info (Binding info)
-- | TypeDecl info (Name info) (Type info)
-- | Action info (Expr info)
-- | Include info Text
-- | WrongDecl Error
instance HasErrors (Binding i) where
errors = \case
Irrefutable _ a b -> errors a <> errors b
Function _ _ a b c d -> errors a <> errors b <> errors c <> errors d
Var _ a b c -> errors a <> errors b <> errors c
Const _ a b c -> errors a <> errors b <> errors c
WrongBinding e -> return e
-- data Binding info
-- = Irrefutable info (Pattern info) (Expr info)
-- | Function info Bool (Name info) [VarDecl info] (Type info) (Expr info)
-- | Var info (Name info) (Type info) (Expr info)
-- | Const info (Name info) (Type info) (Expr info)
-- | WrongBinding Error
instance HasErrors (VarDecl i) where
errors = \case
Decl _ a b c -> errors a <> errors b <> errors c
WrongVarDecl e -> return e
-- data VarDecl info
-- = Decl info (Mutable info) (Name info) (Type info)
-- | WrongVarDecl Error
instance HasErrors (Mutable i) where
errors = \case
WrongMutable e -> return e
_ -> fail "none"
-- data Mutable info
-- = Mutable info
-- | Immutable info
-- | WrongMutable Error
instance HasErrors (Type i) where
errors = \case
TArrow _ a b -> errors a <> errors b
TRecord _ fs -> errors fs
TVar _ a -> errors a
TSum _ cs -> errors cs
TProduct _ es -> errors es
TApply _ f xs -> errors f <> errors xs
-- data Type info
-- = TArrow info (Type info) (Type info)
-- | TRecord info [TField info]
-- | TVar info (Name info)
-- | TSum info [Variant info]
-- | TProduct info [Type info]
-- | TApply info (Name info) [Type info]
-- | WrongType Error
instance HasErrors (Variant i) where
errors = \case
Variant _ a b -> errors a <> errors b
WrongVariant e -> return e
-- data Variant info
-- = Variant info (Name info) (Maybe (Type info))
-- | WrongVariant Error
instance HasErrors (TField i) where
errors = \case
TField _ a b -> errors a <> errors b
WrongTField e -> return e
-- data TField info
-- = TField info (Name info) (Type info)
-- | WrongTField Error
instance HasErrors (Expr i) where
errors = \case
Let _ ds b -> errors ds <> errors b
Apply _ f xs -> errors f <> errors xs
Constant _ c -> errors c
Ident _ q -> errors q
BinOp _ l _ r -> errors l <> errors r
UnOp _ _ o -> errors o
Record _ fs -> errors fs
If _ a b c -> errors a <> errors b <> errors c
Assign _ a b -> errors a <> errors b
List _ l -> errors l
Set _ l -> errors l
Tuple _ l -> errors l
Annot _ a b -> errors a <> errors b
Attrs _ _ -> fail "none"
BigMap _ l -> errors l
Map _ l -> errors l
MapRemove _ a b -> errors a <> errors b
SetRemove _ a b -> errors a <> errors b
Indexing _ a b -> errors a <> errors b
Case _ a bs -> errors a <> errors bs
Skip _ -> fail "none"
ForLoop _ a b c d -> errors a <> errors b <> errors c <> errors d
WhileLoop _ a b -> errors a <> errors b
Seq _ ds -> errors ds
Lambda _ ps b c -> errors ps <> errors b <> errors c
ForBox _ a b _ c d -> errors a <> errors b <> errors c <> errors d
MapPatch _ a bs -> errors a <> errors bs
SetPatch _ a bs -> errors a <> errors bs
RecordUpd _ a bs -> errors a <> errors bs
WrongExpr e -> return e
-- data Expr info
-- = Let info [Declaration info] (Expr info)
-- | Apply info (Expr info) [Expr info]
-- | Constant info (Constant info)
-- | Ident info (QualifiedName info)
-- | BinOp info (Expr info) Text (Expr info)
-- | UnOp info Text (Expr info)
-- | Record info [Assignment info]
-- | If info (Expr info) (Expr info) (Expr info)
-- | Assign info (LHS info) (Expr info)
-- | List info [Expr info]
-- | Set info [Expr info]
-- | Tuple info [Expr info]
-- | Annot info (Expr info) (Type info)
-- | Attrs info [Text]
-- | BigMap info [MapBinding info]
-- | Map info [MapBinding info]
-- | MapRemove info (Expr info) (QualifiedName info)
-- | SetRemove info (Expr info) (QualifiedName info)
-- | Indexing info (QualifiedName info) (Expr info)
-- | Case info (Expr info) [Alt info]
-- | Skip info
-- | ForLoop info (Name info) (Expr info) (Expr info) (Expr info)
-- | WhileLoop info (Expr info) (Expr info)
-- | Seq info [Declaration info]
-- | Lambda info [VarDecl info] (Type info) (Expr info)
-- | ForBox info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info)
-- | MapPatch info (QualifiedName info) [MapBinding info]
-- | SetPatch info (QualifiedName info) [Expr info]
-- | RecordUpd info (QualifiedName info) [FieldAssignment info]
-- | WrongExpr Error
instance HasErrors (Alt i) where
errors = \case
Alt _ a b -> errors a <> errors b
WrongAlt e -> return e
-- data Alt info
-- = Alt info (Pattern info) (Expr info)
-- | WrongAlt Error
instance HasErrors (LHS i) where
errors = \case
LHS _ a b -> errors a <> errors b
WrongLHS e -> return e
-- data LHS info
-- = LHS info (QualifiedName info) (Maybe (Expr info))
-- | WrongLHS Error
instance HasErrors (MapBinding i) where
errors = \case
MapBinding _ a b -> errors a <> errors b
WrongMapBinding e -> return e
-- data MapBinding info
-- = MapBinding info (Expr info) (Expr info)
-- | WrongMapBinding Error
instance HasErrors (Assignment i) where
errors = \case
Assignment _ a b -> errors a <> errors b
WrongAssignment e -> return e
-- data Assignment info
-- = Assignment info (Name info) (Expr info)
-- | WrongAssignment Error
instance HasErrors (FieldAssignment i) where
errors = \case
FieldAssignment _ a b -> errors a <> errors b
WrongFieldAssignment e -> return e
-- data FieldAssignment info
-- = FieldAssignment info (QualifiedName info) (Expr info)
-- | WrongFieldAssignment Error
instance HasErrors (Constant i) where
errors = \case
WrongConstant e -> return e
_ -> fail "none"
-- data Constant info
-- = Int info Text
-- | Nat info Text
-- | String info Text
-- | Float info Text
-- | Bytes info Text
-- | Tez info Text
-- | WrongConstant Error
instance HasErrors (Pattern i) where
errors = \case
IsConstr _ a b -> errors a <> errors b
IsConstant _ c -> errors c
IsVar _ a -> errors a
IsCons _ a b -> errors a <> errors b
IsWildcard _ -> fail "none"
IsList _ l -> errors l
IsTuple _ l -> errors l
WrongPattern e -> return e
-- data Pattern info
-- = IsConstr info (Name info) (Maybe (Pattern info))
-- | IsConstant info (Constant info)
-- | IsVar info (Name info)
-- | IsCons info (Pattern info) (Pattern info)
-- | IsWildcard info
-- | IsList info [Pattern info]
-- | IsTuple info [Pattern info]
-- | WrongPattern Error
instance HasErrors (QualifiedName i) where
errors = \case
QualifiedName _ a b -> errors a <> errors b
WrongQualifiedName e -> return e
-- data QualifiedName info
-- = QualifiedName
-- { qnInfo :: info
-- , qnSource :: Name info
-- , qnPath :: [Path info]
-- }
-- | WrongQualifiedName Error
instance HasErrors (Path i) where
errors = \case
At _ a -> errors a
Ix _ _ -> fail "none"
WrongPath e -> return e
-- data Path info
-- = At info (Name info)
-- | Ix info Text
-- | WrongPath Error
instance HasErrors (Name i) where
errors = \case
WrongName e -> return e
_ -> fail "none"
-- data Name info = Name
-- { info :: info
-- , raw :: Text
-- }
-- | WrongName Error

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

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

View File

@ -0,0 +1,20 @@
module Error where
import Data.Text (Text)
import Pretty
import Range
-- | Parse error.
data Error
= Expected
{ eMsg :: Text -- ^ Description of what was expected.
, eWhole :: Text -- ^ Offending text.
, eRange :: Range -- ^ Location of the error.
}
deriving (Show) via PP Error
instance Pretty Error where
pp (Expected msg found r) = "" <> pp msg <> pp r <> "" <> pp found <> ""

View File

@ -0,0 +1,23 @@
module HasComments where
import qualified Data.Text as Text
import Pretty
class HasComments c where
getComments :: c -> [Text.Text]
c :: HasComments i => i -> Doc -> Doc
c i d =
case getComments i of
[] -> d
cc -> block (map removeSlashN cc) $$ d
where
removeSlashN txt =
if "\n" `Text.isSuffixOf` txt
then Text.init txt
else txt
instance HasComments () where
getComments () = []

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -0,0 +1,28 @@
module Stubbed where
import Control.Lens
import Data.Text (Text, pack)
import Error
-- | For types that have a default replacer with an `Error`.
class Stubbed a where
stubbing :: Error -> a
instance Stubbed Text where
stubbing = pack . show
-- | This is bad, but I had to.
--
-- TODO: Find a way to remove this instance.
-- I probably need a wrapper around '[]'.
--
instance Stubbed [a] where
stubbing = const []
-- | `Nothing` would be bad default replacer.
instance Stubbed a => Stubbed (Maybe a) where
stubbing = Just . stubbing

View File

@ -0,0 +1,105 @@
module Tree where
import Data.Fix
import Data.Functor.Compose
import Union
import Update
import Lattice
import HasComments
import HasErrors
import Pretty
import Error
import Stubbed
-- | Tree is a fixpoint of `Union` @layers@, each equipped with an @info@.
newtype Tree layers info = Tree
{ unTree :: Fix (Either Error `Compose` (,) info `Compose` Union layers)
}
instance (Functor (Union layers)) => Functor (Tree layers) where
fmap f (Tree fixpoint) = Tree $ cata (Fix . go) fixpoint
where
go (Compose (Left err)) = Compose $ Left err
go (Compose (Right (Compose (a, rest)))) =
Compose $ Right $ Compose (f a, rest)
instance
( Functor (Union layers)
, HasComments info
, Pretty (Union layers Doc)
)
=>
Show (Tree layers info)
where
show = show . pp
instance {-# OVERLAPS #-}
( HasComments info
, Functor (Union fs)
, Pretty (Union fs Doc)
)
=>
Pretty (Tree fs info)
where
pp (Tree it) = cata aux it
where
aux (Compose (Left err)) = pp err
aux (Compose (Right (Compose (info, fTree)))) = c info $ pp fTree
-- Return all subtrees that cover the range, ascending in side.
spineTo
:: ( Lattice info
, Foldable (Union fs)
)
=> info
-> Tree fs info
-> [Tree fs info]
spineTo info = reverse . go . unTree
where
go tree@(Fix (Compose (Right (Compose (info', fres))))) =
-- traceShow (info <? info', info, info') $
if info <? info'
then Tree tree : foldMap go fres
else []
go _ = []
-- | Update the tree in the monad that exports its methods.
updateTree
:: ( UpdateOver m (Union fs) (Tree fs a)
, Traversable (Union fs)
)
=> (a -> m b)
-> Tree fs a -> m (Tree fs b)
updateTree act = fmap Tree . go . unTree
where
go (Fix (Compose (Right (Compose (a, union))))) = do
b <- act a
before (Tree <$> union)
union' <- traverse go union
after (Tree <$> union)
return (Fix (Compose (Right (Compose (b, union')))))
go (Fix (Compose (Left err))) = do
return (Fix (Compose (Left err)))
-- | Make a tree out of a layer and an info.
mk :: (Functor f, Member f fs) => info -> f (Tree fs info) -> Tree fs info
mk i fx = Tree $ Fix $ Compose $ Right $ Compose (i, inj $ fmap unTree fx)
infoOf :: Tree fs info -> Maybe info
infoOf (Tree (Fix (Compose it))) =
either
(const Nothing)
(Just . fst . getCompose) it
instance Stubbed (Tree fs info) where
stubbing = Tree . Fix . Compose . Left
instance Foldable (Union fs) => HasErrors (Tree fs info) where
errors = go . unTree
where
go (Fix (Compose (Left err))) = pure err
go (Fix rest) = foldMap go rest

View File

@ -0,0 +1,77 @@
module Union
( Union(..), eliminate
, Member, proj, inj
)
where
import Update
import Pretty
{-
The "one of" datatype.
Each `Union fs a` is a `f a`, where `f` is one of `fs`.
-}
data Union fs x where
Here :: f x -> Union (f : fs) x
There :: Union fs x -> Union (f : fs) x
instance Eq (Union '[] a) where (==) = error "Union.empty"
instance Show (Union '[] a) where show = error "Union.empty"
instance Functor (Union '[]) where fmap = error "Union.empty"
instance Foldable (Union '[]) where foldMap = error "Union.empty"
instance Traversable (Union '[]) where traverse = error "Union.empty"
instance (Eq (f a), Eq (Union fs a)) => Eq (Union (f : fs) a) where
a == b = case (a, b) of
(Here a', Here b') -> a' == b'
(There a', There b') -> a' == b'
_ -> False
instance (Show (f a), Show (Union fs a)) => Show (Union (f : fs) a) where
show = eliminate show show
deriving stock instance (Functor f, Functor (Union fs)) => Functor (Union (f : fs))
deriving stock instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f : fs))
deriving stock instance (Traversable f, Traversable (Union fs)) => Traversable (Union (f : fs))
{-
A case over `Union`.
-}
eliminate
:: (f x -> a)
-> (Union fs x -> a)
-> (Union (f : fs) x -> a)
eliminate here there = \case
Here fx -> here fx
There rest -> there rest
{-
The `f` functior is in the `fs` list.
-}
class Member f fs where
inj :: f x -> Union fs x -- embed f into some Union
proj :: Union fs x -> Maybe (f x) -- check if a Union is actually f
instance {-# OVERLAPS #-} Member f (f : fs) where
inj = Here
proj = eliminate Just (const Nothing)
instance Member f fs => Member f (g : fs) where
inj = There . inj
proj = eliminate (const Nothing) proj
instance HasMethods m => UpdateOver m (Union '[]) a where
before = error "Union.empty"
after = error "Union.empty"
instance (HasMethods m, UpdateOver m f a, UpdateOver m (Union fs) a) => UpdateOver m (Union (f : fs)) a where
before = eliminate before before
after = eliminate after after
instance Pretty1 (Union '[]) where
pp1 = error "Union.empty"
instance (Pretty1 f, Pretty1 (Union fs)) => Pretty1 (Union (f : fs)) where
pp1 = eliminate pp1 pp1

View File

@ -0,0 +1,22 @@
module Update where
{-
Abstraction over monad capabilities.
-}
class Monad m => HasMethods m where
data Methods m :: *
method :: Methods m
{-
Given some AST structure, do some stuff before & after it is traversed.
-}
class HasMethods m => UpdateOver m f a where
before :: f a -> m ()
after :: f a -> m ()
before _ = skip
after _ = skip
skip :: Monad m => m ()
skip = return ()