[LIGO-6] Implement fallback scope system

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

tools/lsp/squirrel/package.yaml

@@ -24,6 +24,9 @@ default-extensions:
   - ScopedTypeVariables
   - QuasiQuotes
   - TemplateHaskell
+  - DeriveFunctor
+  - DeriveFoldable
+  - DeriveTraversable
 
 ghc-options: -freverse-errors -Wall -threaded
 

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

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

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

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
+  { _info    :: info
-  , raw     :: Text
+  , _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

tools/lsp/squirrel/src/Range.hs

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