From 67de82edec90a1ec1037105ac9f9af018cc6ec30 Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Thu, 21 May 2020 23:28:26 +0400 Subject: [PATCH] [LIGO-6] Implement fallback scope system --- tools/lsp/squirrel/app/Main.hs | 18 + tools/lsp/squirrel/package.yaml | 3 + tools/lsp/squirrel/squirrel.cabal | 7 +- tools/lsp/squirrel/src/AST.hs | 1 + tools/lsp/squirrel/src/AST/Scope.hs | 796 ++++++++++++++++++++++++++++ tools/lsp/squirrel/src/AST/Types.hs | 44 +- tools/lsp/squirrel/src/Range.hs | 7 +- 7 files changed, 853 insertions(+), 23 deletions(-) create mode 100644 tools/lsp/squirrel/src/AST/Scope.hs diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index d019eab63..8f9699481 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -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 diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index 5177661ba..c95d23222 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -24,6 +24,9 @@ default-extensions: - ScopedTypeVariables - QuasiQuotes - TemplateHaskell + - DeriveFunctor + - DeriveFoldable + - DeriveTraversable ghc-options: -freverse-errors -Wall -threaded diff --git a/tools/lsp/squirrel/squirrel.cabal b/tools/lsp/squirrel/squirrel.cabal index eca3096ae..0d298d516 100644 --- a/tools/lsp/squirrel/squirrel.cabal +++ b/tools/lsp/squirrel/squirrel.cabal @@ -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 diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index 3e45b28ad..f80972b04 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/tools/lsp/squirrel/src/AST.hs @@ -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 diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs new file mode 100644 index 000000000..ec151e636 --- /dev/null +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -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 diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index 3f13eb296..159501541 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/tools/lsp/squirrel/src/AST/Types.hs @@ -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 diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index beadaf383..4ba76382f 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/tools/lsp/squirrel/src/Range.hs @@ -1,6 +1,8 @@ module Range where +import Control.Lens + import Pretty -- | A continuous location in text. @@ -17,4 +19,7 @@ diffRange (Range ws wf) (Range ps _) = Range (max ws ps) wf instance Pretty Range where pp (Range (ll, lc, _) (rl, rc, _)) = brackets do - int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc \ No newline at end of file + int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc + +class HasRange a where + location :: Lens' a Range \ No newline at end of file