[LIGO-6] Implement fallback scope system
This commit is contained in:
Kirill Andreev
parent
1536590edb
commit
67de82edec
@ -86,6 +86,23 @@ eventLoop funs chan = do
|
||||
$ fmServerRegisterCapabilityRequest rid registrations
|
||||
|
||||
NotDidOpenTextDocument notif -> do
|
||||
let
|
||||
doc = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.uri
|
||||
|
||||
ver = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.version
|
||||
|
||||
collectErrors funs
|
||||
(J.toNormalizedUri doc)
|
||||
(J.uriToFilePath doc)
|
||||
(Just ver)
|
||||
|
||||
NotDidChangeTextDocument notif -> do
|
||||
let
|
||||
doc = notif
|
||||
^.J.params
|
||||
@ -97,6 +114,7 @@ eventLoop funs chan = do
|
||||
(J.uriToFilePath doc)
|
||||
(Just 0)
|
||||
|
||||
|
||||
collectErrors
|
||||
:: Core.LspFuncs ()
|
||||
-> J.NormalizedUri
|
||||
|
||||
@ -24,6 +24,9 @@ default-extensions:
|
||||
- ScopedTypeVariables
|
||||
- QuasiQuotes
|
||||
- TemplateHaskell
|
||||
- DeriveFunctor
|
||||
- DeriveFoldable
|
||||
- DeriveTraversable
|
||||
|
||||
ghc-options: -freverse-errors -Wall -threaded
|
||||
|
||||
|
||||
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 538d4e2f89a920b2395b5b445d883e29cf753fa91e443e1308a48a689018f4eb
|
||||
-- hash: e30e95968ee812129049606c1bdd5ab3a97ce79d1da5f70f38adaf4bc91f4a4a
|
||||
|
||||
name: squirrel
|
||||
version: 0.0.0
|
||||
@ -15,6 +15,7 @@ library
|
||||
AST
|
||||
AST.Errors
|
||||
AST.Parser
|
||||
AST.Scope
|
||||
AST.Types
|
||||
Parser
|
||||
ParseTree
|
||||
@ -25,7 +26,7 @@ library
|
||||
Paths_squirrel
|
||||
hs-source-dirs:
|
||||
src/
|
||||
default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell
|
||||
default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell DeriveFunctor DeriveFoldable DeriveTraversable
|
||||
ghc-options: -freverse-errors -Wall -threaded
|
||||
include-dirs:
|
||||
vendor
|
||||
@ -49,7 +50,7 @@ executable squirrel
|
||||
Paths_squirrel
|
||||
hs-source-dirs:
|
||||
app/
|
||||
default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell
|
||||
default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell DeriveFunctor DeriveFoldable DeriveTraversable
|
||||
ghc-options: -freverse-errors -Wall -threaded
|
||||
build-depends:
|
||||
base
|
||||
|
||||
@ -4,3 +4,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
|
||||
|
||||
796
tools/lsp/squirrel/src/AST/Scope.hs
Normal file
796
tools/lsp/squirrel/src/AST/Scope.hs
Normal file
@ -0,0 +1,796 @@
|
||||
|
||||
{-
|
||||
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.Scope where
|
||||
|
||||
import Control.Lens hiding (Const, List)
|
||||
import Control.Monad.State
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
import Data.Foldable
|
||||
|
||||
import Parser
|
||||
import Range
|
||||
import AST.Types
|
||||
|
||||
class UpdatableScopes a where
|
||||
updateScopes :: HasRange r => (r -> ScopeM s) -> a r -> ScopeM (a s)
|
||||
|
||||
type ScopeM = State [Env]
|
||||
|
||||
newtype Env = Env
|
||||
{ _eDecls :: [ScopedDecl]
|
||||
}
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
data ScopedDecl = ScopedDecl
|
||||
{ _sdName :: Maybe Text
|
||||
, _sdOrigin :: Maybe Range
|
||||
, _sdBody :: Maybe Range
|
||||
, _sdType :: Maybe (Either (Type ()) Kind)
|
||||
}
|
||||
|
||||
data Kind = Star
|
||||
|
||||
block :: ScopeM a -> ScopeM a
|
||||
block action = do
|
||||
modify \(top : rest) -> top : top : rest -- inheriting outer scope
|
||||
res <- action
|
||||
modify tail -- dropping current frame
|
||||
return res
|
||||
|
||||
define :: ScopedDecl -> ScopeM ()
|
||||
define sd = do
|
||||
modify \(Env top : rest) -> Env (sd : top) : rest
|
||||
|
||||
def
|
||||
:: ( HasRange i
|
||||
, Foldable g
|
||||
, Stubbed (g i)
|
||||
)
|
||||
=> Name i
|
||||
-> g i
|
||||
-> Type j
|
||||
-> ScopeM ()
|
||||
def n b ty =
|
||||
define $ ScopedDecl
|
||||
(n^?raw)
|
||||
(n^?folded.location)
|
||||
(b^?treeRange)
|
||||
(Just $ Left $ void ty)
|
||||
|
||||
defP
|
||||
:: ( HasRange i
|
||||
, Foldable g
|
||||
, Stubbed (g i)
|
||||
)
|
||||
=> Name i
|
||||
-> g i
|
||||
-> Maybe (Type j)
|
||||
-> ScopeM ()
|
||||
defP n b mty =
|
||||
define $ ScopedDecl
|
||||
(n^?raw)
|
||||
(n^?folded.location)
|
||||
(b^?treeRange)
|
||||
(fmap (Left . void) mty)
|
||||
|
||||
defParam
|
||||
:: ( HasRange i
|
||||
)
|
||||
=> Name i
|
||||
-> Type j
|
||||
-> ScopeM ()
|
||||
defParam n ty =
|
||||
define $ ScopedDecl
|
||||
(n^?raw)
|
||||
(n^?folded.location)
|
||||
Nothing
|
||||
(Just $ Left $ void ty)
|
||||
|
||||
defI
|
||||
:: ( HasRange i
|
||||
)
|
||||
=> Name i
|
||||
-> ScopeM ()
|
||||
defI n =
|
||||
define $ ScopedDecl
|
||||
(n^?raw)
|
||||
(n^?folded.location)
|
||||
Nothing
|
||||
Nothing
|
||||
|
||||
defE
|
||||
:: ( HasRange i
|
||||
, Foldable f
|
||||
, Stubbed (f i)
|
||||
)
|
||||
=> Name i
|
||||
-> f i
|
||||
-> ScopeM ()
|
||||
defE n b =
|
||||
define $ ScopedDecl
|
||||
(n^?raw)
|
||||
(n^?folded.location)
|
||||
(b^?treeRange)
|
||||
Nothing
|
||||
|
||||
defType
|
||||
:: ( Foldable g
|
||||
, HasRange i
|
||||
, Stubbed (g i)
|
||||
)
|
||||
=> Name i
|
||||
-> g i
|
||||
-> Kind
|
||||
-> ScopeM ()
|
||||
defType n b ki =
|
||||
define $ ScopedDecl
|
||||
(n^?raw)
|
||||
(n^?folded.location)
|
||||
(b^?treeRange)
|
||||
(Just (Right ki))
|
||||
|
||||
treeRange
|
||||
:: ( Foldable f
|
||||
, HasRange a
|
||||
, Stubbed (f a)
|
||||
)
|
||||
=> Fold (f a) Range
|
||||
treeRange = folded.location
|
||||
|
||||
instance UpdatableScopes Contract where
|
||||
updateScopes update = \case
|
||||
Contract i ds -> do
|
||||
block do
|
||||
Contract
|
||||
<$> update i
|
||||
<*> for ds (updateScopes update)
|
||||
|
||||
WrongContract e -> do
|
||||
return $ WrongContract e
|
||||
|
||||
|
||||
-- data Contract info
|
||||
-- = Contract info [Declaration info]
|
||||
-- | WrongContract Error
|
||||
|
||||
instance UpdatableScopes Declaration where
|
||||
updateScopes update = \case
|
||||
ValueDecl i bind -> do
|
||||
ValueDecl
|
||||
<$> update i
|
||||
<*> updateScopes update bind
|
||||
|
||||
TypeDecl i n ty -> do
|
||||
defType n ty Star
|
||||
|
||||
TypeDecl
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> updateScopes update ty
|
||||
|
||||
Action i expr -> do
|
||||
Action
|
||||
<$> update i
|
||||
<*> updateScopes update expr
|
||||
|
||||
Include i s -> do
|
||||
Include
|
||||
<$> update i
|
||||
<*> pure s
|
||||
|
||||
WrongDecl e -> do
|
||||
return $ WrongDecl e
|
||||
|
||||
-- data Declaration info
|
||||
-- = ValueDecl info (Binding info)
|
||||
-- | TypeDecl info (Name info) (Type info)
|
||||
-- | Action info (Expr info)
|
||||
-- | Include info Text
|
||||
-- | WrongDecl Error
|
||||
|
||||
instance UpdatableScopes Binding where
|
||||
updateScopes update = \case
|
||||
Irrefutable i p e -> do
|
||||
res <- Irrefutable
|
||||
<$> update i
|
||||
<*> updateScopes update p
|
||||
<*> updateScopes update e
|
||||
|
||||
for_ (p^..patternNames) \name -> do
|
||||
defE name e
|
||||
|
||||
return res
|
||||
|
||||
Function i recur n params ty body -> do
|
||||
let
|
||||
returns = telescope ((void) <$> params)
|
||||
defineHere = def n body (returns (void ty))
|
||||
|
||||
when recur do
|
||||
defineHere
|
||||
|
||||
res <- block do
|
||||
Function
|
||||
<$> update i
|
||||
<*> pure recur
|
||||
<*> updateScopes update n
|
||||
<*> traverse (updateScopes update) params
|
||||
<*> updateScopes update ty
|
||||
<*> updateScopes update body
|
||||
|
||||
unless recur do
|
||||
defineHere
|
||||
|
||||
return res
|
||||
|
||||
Var i n ty e -> do
|
||||
res <- Var
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> updateScopes update ty
|
||||
<*> updateScopes update e
|
||||
|
||||
def n e ty
|
||||
|
||||
return res
|
||||
|
||||
Const i n ty e -> do
|
||||
res <- Const
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> updateScopes update ty
|
||||
<*> updateScopes update e
|
||||
|
||||
def n e ty
|
||||
|
||||
return res
|
||||
|
||||
WrongBinding e -> do
|
||||
return $ WrongBinding e
|
||||
|
||||
telescope :: [VarDecl i] -> Type () -> Type ()
|
||||
telescope = flip $ foldr \case
|
||||
Decl _ _ _ ty -> TArrow () (void ty)
|
||||
WrongVarDecl e -> TArrow () (WrongType e)
|
||||
|
||||
-- data Binding info
|
||||
-- = Irrefutable info (Pattern info) (Expr info)
|
||||
-- | Function info Bool (Name info) [VarDecl info] (Type info) (Expr info)
|
||||
-- | Var info (Name info) (Type info) (Expr info)
|
||||
-- | Const info (Name info) (Type info) (Expr info)
|
||||
-- | WrongBinding Error
|
||||
|
||||
instance UpdatableScopes VarDecl where
|
||||
updateScopes update = \case
|
||||
Decl i mut n ty -> do
|
||||
res <- Decl
|
||||
<$> update i
|
||||
<*> updateScopes update mut
|
||||
<*> updateScopes update n
|
||||
<*> updateScopes update ty
|
||||
|
||||
defParam n ty
|
||||
|
||||
return res
|
||||
|
||||
WrongVarDecl e -> do
|
||||
return $ WrongVarDecl e
|
||||
|
||||
-- data VarDecl info
|
||||
-- = Decl info (Mutable info) (Name info) (Type info)
|
||||
-- | WrongVarDecl Error
|
||||
|
||||
instance UpdatableScopes Mutable where
|
||||
updateScopes update = \case
|
||||
Mutable i -> Mutable <$> update i
|
||||
Immutable i -> Immutable <$> update i
|
||||
WrongMutable e -> return $ WrongMutable e
|
||||
|
||||
-- data Mutable info
|
||||
-- = Mutable info
|
||||
-- | Immutable info
|
||||
-- | WrongMutable Error
|
||||
|
||||
instance UpdatableScopes Type where
|
||||
updateScopes update = \case
|
||||
TArrow i cod dom -> do
|
||||
TArrow
|
||||
<$> update i
|
||||
<*> updateScopes update cod
|
||||
<*> updateScopes update dom
|
||||
|
||||
TRecord i fs -> do
|
||||
TRecord
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) fs
|
||||
|
||||
TVar i n -> do
|
||||
TVar
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
|
||||
TSum i vs -> do
|
||||
TSum
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) vs
|
||||
|
||||
TProduct i es -> do
|
||||
TProduct
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) es
|
||||
|
||||
TApply i f xs -> do
|
||||
TApply
|
||||
<$> update i
|
||||
<*> updateScopes update f
|
||||
<*> traverse (updateScopes update) xs
|
||||
|
||||
WrongType e -> do
|
||||
return $ WrongType e
|
||||
|
||||
-- data Type info
|
||||
-- = TArrow info (Type info) (Type info)
|
||||
-- | TRecord info [TField info]
|
||||
-- | TVar info (Name info)
|
||||
-- | TSum info [Variant info]
|
||||
-- | TProduct info [Type info]
|
||||
-- | TApply info (Name info) [Type info]
|
||||
-- | WrongType Error
|
||||
|
||||
instance UpdatableScopes Variant where
|
||||
updateScopes update = \case
|
||||
Variant i n mty -> do
|
||||
res <- Variant
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> traverse (updateScopes update) mty
|
||||
|
||||
defParam n $ case mty of
|
||||
Just it -> TArrow () (void it) (TVar () (Name () "unknown"))
|
||||
Nothing -> TVar () (Name () "unknown")
|
||||
|
||||
return res
|
||||
|
||||
WrongVariant e -> do
|
||||
return $ WrongVariant e
|
||||
|
||||
-- data Variant info
|
||||
-- = Variant info (Name info) (Maybe (Type info))
|
||||
-- | WrongVariant Error
|
||||
|
||||
instance UpdatableScopes TField where
|
||||
updateScopes update = \case
|
||||
TField i a b -> do
|
||||
TField
|
||||
<$> update i
|
||||
<*> updateScopes update a
|
||||
<*> updateScopes update b
|
||||
|
||||
WrongTField e -> do
|
||||
return $ WrongTField e
|
||||
|
||||
-- data TField info
|
||||
-- = TField info (Name info) (Type info)
|
||||
-- | WrongTField Error
|
||||
|
||||
instance UpdatableScopes Expr where
|
||||
updateScopes update = \case
|
||||
Let i ds b -> do
|
||||
s <- update i
|
||||
block do
|
||||
Let s
|
||||
<$> traverse (updateScopes update) ds
|
||||
<*> updateScopes update b
|
||||
|
||||
Apply i f xs ->
|
||||
Apply
|
||||
<$> update i
|
||||
<*> updateScopes update f
|
||||
<*> traverse (updateScopes update) xs
|
||||
|
||||
Constant i c ->
|
||||
Constant
|
||||
<$> update i
|
||||
<*> updateScopes update c
|
||||
|
||||
Ident i qn -> do
|
||||
Ident
|
||||
<$> update i
|
||||
<*> updateScopes update qn
|
||||
|
||||
BinOp i l op r -> do
|
||||
BinOp
|
||||
<$> update i
|
||||
<*> updateScopes update l
|
||||
<*> pure op
|
||||
<*> updateScopes update r
|
||||
|
||||
UnOp i op r -> do
|
||||
UnOp
|
||||
<$> update i
|
||||
<*> pure op
|
||||
<*> updateScopes update r
|
||||
|
||||
Record i fs -> do
|
||||
Record
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) fs
|
||||
|
||||
If i a b c -> do
|
||||
If
|
||||
<$> update i
|
||||
<*> updateScopes update a
|
||||
<*> updateScopes update b
|
||||
<*> updateScopes update c
|
||||
|
||||
Assign i l r -> do
|
||||
Assign
|
||||
<$> update i
|
||||
<*> updateScopes update l
|
||||
<*> updateScopes update r
|
||||
|
||||
List i ls -> do
|
||||
List
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) ls
|
||||
|
||||
Set i ls -> do
|
||||
Set
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) ls
|
||||
|
||||
Tuple i ls -> do
|
||||
Tuple
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) ls
|
||||
|
||||
Annot i e ty -> do
|
||||
Annot
|
||||
<$> update i
|
||||
<*> updateScopes update e
|
||||
<*> updateScopes update ty
|
||||
|
||||
Attrs i az -> do
|
||||
Attrs
|
||||
<$> update i
|
||||
<*> pure az
|
||||
|
||||
BigMap i ms -> do
|
||||
BigMap
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) ms
|
||||
|
||||
Map i ms -> do
|
||||
Map
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) ms
|
||||
|
||||
MapRemove i e qn -> do
|
||||
MapRemove
|
||||
<$> update i
|
||||
<*> updateScopes update e
|
||||
<*> updateScopes update qn
|
||||
|
||||
SetRemove i e qn -> do
|
||||
SetRemove
|
||||
<$> update i
|
||||
<*> updateScopes update e
|
||||
<*> updateScopes update qn
|
||||
|
||||
Indexing i q e -> do
|
||||
Indexing
|
||||
<$> update i
|
||||
<*> updateScopes update q
|
||||
<*> updateScopes update e
|
||||
|
||||
Case i e az -> do
|
||||
Case
|
||||
<$> update i
|
||||
<*> updateScopes update e
|
||||
<*> traverse (updateScopes update) az
|
||||
|
||||
Skip i -> Skip <$> update i
|
||||
|
||||
ForLoop i n a b c -> do
|
||||
block do
|
||||
defI n
|
||||
ForLoop
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> updateScopes update a
|
||||
<*> updateScopes update b
|
||||
<*> updateScopes update c
|
||||
|
||||
WhileLoop i a b -> do
|
||||
WhileLoop
|
||||
<$> update i
|
||||
<*> updateScopes update a
|
||||
<*> updateScopes update b
|
||||
|
||||
Seq i ds -> do
|
||||
block do
|
||||
Seq
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) ds
|
||||
|
||||
Lambda i ps ty b -> do
|
||||
block do
|
||||
Lambda
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) ps
|
||||
<*> updateScopes update ty
|
||||
<*> updateScopes update b
|
||||
|
||||
ForBox i a mb t e f -> do
|
||||
block do
|
||||
defI a
|
||||
ForBox
|
||||
<$> update i
|
||||
<*> updateScopes update a
|
||||
<*> traverse (updateScopes update) mb
|
||||
<*> pure t
|
||||
<*> updateScopes update e
|
||||
<*> updateScopes update f
|
||||
|
||||
MapPatch i q bs -> do
|
||||
MapPatch
|
||||
<$> update i
|
||||
<*> updateScopes update q
|
||||
<*> traverse (updateScopes update) bs
|
||||
|
||||
SetPatch i q bs -> do
|
||||
SetPatch
|
||||
<$> update i
|
||||
<*> updateScopes update q
|
||||
<*> traverse (updateScopes update) bs
|
||||
|
||||
RecordUpd i q fs -> do
|
||||
RecordUpd
|
||||
<$> update i
|
||||
<*> updateScopes update q
|
||||
<*> traverse (updateScopes update) fs
|
||||
|
||||
WrongExpr e -> do
|
||||
return $ WrongExpr e
|
||||
|
||||
-- data Expr info
|
||||
-- = Let info [Declaration info] (Expr info)
|
||||
-- | Apply info (Expr info) [Expr info]
|
||||
-- | Constant info (Constant info)
|
||||
-- | Ident info (QualifiedName info)
|
||||
-- | BinOp info (Expr info) Text (Expr info)
|
||||
-- | UnOp info Text (Expr info)
|
||||
-- | Record info [Assignment info]
|
||||
-- | If info (Expr info) (Expr info) (Expr info)
|
||||
-- | Assign info (LHS info) (Expr info)
|
||||
-- | List info [Expr info]
|
||||
-- | Set info [Expr info]
|
||||
-- | Tuple info [Expr info]
|
||||
-- | Annot info (Expr info) (Type info)
|
||||
-- | Attrs info [Text]
|
||||
-- | BigMap info [MapBinding info]
|
||||
-- | Map info [MapBinding info]
|
||||
-- | MapRemove info (Expr info) (QualifiedName info)
|
||||
-- | SetRemove info (Expr info) (QualifiedName info)
|
||||
-- | Indexing info (QualifiedName info) (Expr info)
|
||||
-- | Case info (Expr info) [Alt info]
|
||||
-- | Skip info
|
||||
-- | ForLoop info (Name info) (Expr info) (Expr info) (Expr info)
|
||||
-- | WhileLoop info (Expr info) (Expr info)
|
||||
-- | Seq info [Declaration info]
|
||||
-- | Lambda info [VarDecl info] (Type info) (Expr info)
|
||||
-- | ForBox info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info)
|
||||
-- | MapPatch info (QualifiedName info) [MapBinding info]
|
||||
-- | SetPatch info (QualifiedName info) [Expr info]
|
||||
-- | RecordUpd info (QualifiedName info) [FieldAssignment info]
|
||||
-- | WrongExpr Error
|
||||
|
||||
instance UpdatableScopes Alt where
|
||||
updateScopes update = \case
|
||||
Alt i p e -> do
|
||||
block do
|
||||
s <- update i
|
||||
p' <- updateScopes update p
|
||||
for_ (p^..patternNames) \name -> do
|
||||
defI name
|
||||
|
||||
Alt s p'
|
||||
<$> updateScopes update e
|
||||
|
||||
WrongAlt e -> do
|
||||
return $ WrongAlt e
|
||||
|
||||
-- data Alt info
|
||||
-- = Alt info (Pattern info) (Expr info)
|
||||
-- | WrongAlt Error
|
||||
|
||||
instance UpdatableScopes LHS where
|
||||
updateScopes update = \case
|
||||
LHS i q me -> do
|
||||
LHS
|
||||
<$> update i
|
||||
<*> updateScopes update q
|
||||
<*> traverse (updateScopes update) me
|
||||
|
||||
WrongLHS e -> do
|
||||
return $ WrongLHS e
|
||||
|
||||
-- data LHS info
|
||||
-- = LHS info (QualifiedName info) (Maybe (Expr info))
|
||||
-- | WrongLHS Error
|
||||
|
||||
instance UpdatableScopes MapBinding where
|
||||
updateScopes update = \case
|
||||
MapBinding i e f -> do
|
||||
MapBinding
|
||||
<$> update i
|
||||
<*> updateScopes update e
|
||||
<*> updateScopes update f
|
||||
|
||||
WrongMapBinding e -> do
|
||||
return $ WrongMapBinding e
|
||||
|
||||
-- data MapBinding info
|
||||
-- = MapBinding info (Expr info) (Expr info)
|
||||
-- | WrongMapBinding Error
|
||||
|
||||
instance UpdatableScopes Assignment where
|
||||
updateScopes update = \case
|
||||
Assignment i n e -> do
|
||||
Assignment
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> updateScopes update e
|
||||
|
||||
WrongAssignment e -> do
|
||||
return $ WrongAssignment e
|
||||
|
||||
-- data Assignment info
|
||||
-- = Assignment info (Name info) (Expr info)
|
||||
-- | WrongAssignment Error
|
||||
|
||||
instance UpdatableScopes FieldAssignment where
|
||||
updateScopes update = \case
|
||||
FieldAssignment i q e -> do
|
||||
FieldAssignment
|
||||
<$> update i
|
||||
<*> updateScopes update q
|
||||
<*> updateScopes update e
|
||||
|
||||
WrongFieldAssignment e -> do
|
||||
return $ WrongFieldAssignment e
|
||||
|
||||
-- data FieldAssignment info
|
||||
-- = FieldAssignment info (QualifiedName info) (Expr info)
|
||||
-- | WrongFieldAssignment Error
|
||||
|
||||
instance UpdatableScopes Constant where
|
||||
updateScopes update = \case
|
||||
Int i t -> Int <$> update i <*> pure t
|
||||
Nat i t -> Nat <$> update i <*> pure t
|
||||
String i t -> String <$> update i <*> pure t
|
||||
Float i t -> Float <$> update i <*> pure t
|
||||
Bytes i t -> Bytes <$> update i <*> pure t
|
||||
Tez i t -> Tez <$> update i <*> pure t
|
||||
WrongConstant e -> return $ WrongConstant e
|
||||
|
||||
-- data Constant info
|
||||
-- = Int info Text
|
||||
-- | Nat info Text
|
||||
-- | String info Text
|
||||
-- | Float info Text
|
||||
-- | Bytes info Text
|
||||
-- | Tez info Text
|
||||
-- | WrongConstant Error
|
||||
|
||||
patternNames :: Fold (Pattern i) (Name i)
|
||||
patternNames act = go
|
||||
where
|
||||
go = \case
|
||||
IsConstr i n p -> IsConstr i <$> act n <*> traverse go p
|
||||
IsConstant i c -> pure $ IsConstant i c
|
||||
IsVar i n -> IsVar i <$> act n
|
||||
IsCons i h t -> IsCons i <$> go h <*> go t
|
||||
IsWildcard i -> pure $ IsWildcard i
|
||||
IsList i ps -> IsList i <$> traverse go ps
|
||||
IsTuple i ps -> IsTuple i <$> traverse go ps
|
||||
WrongPattern e -> pure $ WrongPattern e
|
||||
|
||||
instance UpdatableScopes Pattern where
|
||||
updateScopes update = \case
|
||||
IsConstr i n mp -> do
|
||||
IsConstr
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> traverse (updateScopes update) mp
|
||||
|
||||
IsConstant i c -> do
|
||||
IsConstant
|
||||
<$> update i
|
||||
<*> updateScopes update c
|
||||
|
||||
IsVar i n -> do
|
||||
IsVar
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
|
||||
IsCons i h t ->
|
||||
IsCons
|
||||
<$> update i
|
||||
<*> updateScopes update h
|
||||
<*> updateScopes update t
|
||||
|
||||
IsWildcard i -> IsWildcard <$> update i
|
||||
|
||||
IsList i l ->
|
||||
IsList
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) l
|
||||
|
||||
IsTuple i l ->
|
||||
IsTuple
|
||||
<$> update i
|
||||
<*> traverse (updateScopes update) l
|
||||
|
||||
WrongPattern e -> do
|
||||
return $ WrongPattern e
|
||||
|
||||
-- data Pattern info
|
||||
-- = IsConstr info (Name info) (Maybe (Pattern info))
|
||||
-- | IsConstant info (Constant info)
|
||||
-- | IsVar info (Name info)
|
||||
-- | IsCons info (Pattern info) (Pattern info)
|
||||
-- | IsWildcard info
|
||||
-- | IsList info [Pattern info]
|
||||
-- | IsTuple info [Pattern info]
|
||||
-- | WrongPattern Error
|
||||
|
||||
instance UpdatableScopes QualifiedName where
|
||||
updateScopes update = \case
|
||||
QualifiedName i n ps -> do
|
||||
QualifiedName
|
||||
<$> update i
|
||||
<*> updateScopes update n
|
||||
<*> traverse (updateScopes update) ps
|
||||
|
||||
WrongQualifiedName e -> do
|
||||
return $ WrongQualifiedName e
|
||||
|
||||
-- data QualifiedName info
|
||||
-- = QualifiedName
|
||||
-- { qnInfo :: info
|
||||
-- , qnSource :: Name info
|
||||
-- , qnPath :: [Path info]
|
||||
-- }
|
||||
-- | WrongQualifiedName Error
|
||||
|
||||
instance UpdatableScopes Path where
|
||||
updateScopes update = \case
|
||||
At i n -> At <$> update i <*> updateScopes update n
|
||||
Ix i n -> Ix <$> update i <*> pure n
|
||||
WrongPath e -> return $ WrongPath e
|
||||
|
||||
-- data Path info
|
||||
-- = At info (Name info)
|
||||
-- | Ix info Text
|
||||
-- | WrongPath Error
|
||||
|
||||
instance UpdatableScopes Name where
|
||||
updateScopes update = \case
|
||||
Name i r -> Name <$> update i <*> pure r
|
||||
WrongName e -> do
|
||||
return $ WrongName e
|
||||
|
||||
-- data Name info = Name
|
||||
-- { info :: info
|
||||
-- , raw :: Text
|
||||
-- }
|
||||
-- | WrongName Error
|
||||
@ -27,6 +27,7 @@ data Contract info
|
||||
= Contract info [Declaration info]
|
||||
| WrongContract Error
|
||||
deriving (Show) via PP (Contract info)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Declaration info
|
||||
= ValueDecl info (Binding info)
|
||||
@ -35,7 +36,7 @@ data Declaration info
|
||||
| Include info Text
|
||||
| WrongDecl Error
|
||||
deriving (Show) via PP (Declaration info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Binding info
|
||||
= Irrefutable info (Pattern info) (Expr info)
|
||||
@ -44,20 +45,20 @@ data Binding info
|
||||
| Const info (Name info) (Type info) (Expr info)
|
||||
| WrongBinding Error
|
||||
deriving (Show) via PP (Binding info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data VarDecl info
|
||||
= Decl info (Mutable info) (Name info) (Type info)
|
||||
| WrongVarDecl Error
|
||||
deriving (Show) via PP (VarDecl info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Mutable info
|
||||
= Mutable info
|
||||
| Immutable info
|
||||
| WrongMutable Error
|
||||
deriving (Show) via PP (Mutable info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
|
||||
data Type info
|
||||
@ -69,19 +70,19 @@ data Type info
|
||||
| TApply info (Name info) [Type info]
|
||||
| WrongType Error
|
||||
deriving (Show) via PP (Type info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Variant info
|
||||
= Variant info (Name info) (Maybe (Type info))
|
||||
| WrongVariant Error
|
||||
deriving (Show) via PP (Variant info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data TField info
|
||||
= TField info (Name info) (Type info)
|
||||
| WrongTField Error
|
||||
deriving (Show) via PP (TField info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
-- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls.
|
||||
data Expr info
|
||||
@ -116,37 +117,37 @@ data Expr info
|
||||
| RecordUpd info (QualifiedName info) [FieldAssignment info]
|
||||
| WrongExpr Error
|
||||
deriving (Show) via PP (Expr info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Alt info
|
||||
= Alt info (Pattern info) (Expr info)
|
||||
| WrongAlt Error
|
||||
deriving (Show) via PP (Alt info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data LHS info
|
||||
= LHS info (QualifiedName info) (Maybe (Expr info))
|
||||
| WrongLHS Error
|
||||
deriving (Show) via PP (LHS info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data MapBinding info
|
||||
= MapBinding info (Expr info) (Expr info)
|
||||
| WrongMapBinding Error
|
||||
deriving (Show) via PP (MapBinding info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Assignment info
|
||||
= Assignment info (Name info) (Expr info)
|
||||
| WrongAssignment Error
|
||||
deriving (Show) via PP (Assignment info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data FieldAssignment info
|
||||
= FieldAssignment info (QualifiedName info) (Expr info)
|
||||
| WrongFieldAssignment Error
|
||||
deriving (Show) via PP (FieldAssignment info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Constant info
|
||||
= Int info Text
|
||||
@ -157,7 +158,7 @@ data Constant info
|
||||
| Tez info Text
|
||||
| WrongConstant Error
|
||||
deriving (Show) via PP (Constant info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Pattern info
|
||||
= IsConstr info (Name info) (Maybe (Pattern info))
|
||||
@ -169,7 +170,7 @@ data Pattern info
|
||||
| IsTuple info [Pattern info]
|
||||
| WrongPattern Error
|
||||
deriving (Show) via PP (Pattern info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data QualifiedName info
|
||||
= QualifiedName
|
||||
@ -179,21 +180,22 @@ data QualifiedName info
|
||||
}
|
||||
| WrongQualifiedName Error
|
||||
deriving (Show) via PP (QualifiedName info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Path info
|
||||
= At info (Name info)
|
||||
| Ix info Text
|
||||
| WrongPath Error
|
||||
deriving (Show) via PP (Path info)
|
||||
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Name info = Name
|
||||
{ info :: info
|
||||
, raw :: Text
|
||||
{ _info :: info
|
||||
, _raw :: Text
|
||||
}
|
||||
| WrongName Error
|
||||
deriving (Show) via PP (Name info)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
c :: HasComments i => i -> Doc -> Doc
|
||||
c i d =
|
||||
@ -398,6 +400,10 @@ foldMap makePrisms
|
||||
, ''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
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
|
||||
module Range where
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Pretty
|
||||
|
||||
-- | A continuous location in text.
|
||||
@ -18,3 +20,6 @@ instance Pretty Range where
|
||||
pp (Range (ll, lc, _) (rl, rc, _)) =
|
||||
brackets do
|
||||
int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc
|
||||
|
||||
class HasRange a where
|
||||
location :: Lens' a Range
|
||||
Loading…
Reference in New Issue
Block a user