Implement def/impl/type search

tools/lsp/squirrel/app/Main.hs

@@ -25,6 +25,7 @@ import           Parser
 import           Range
 import           AST hiding (def)
 import           Error
+import           Tree
 
 main :: IO ()
 main = do
@@ -149,6 +150,9 @@ eventLoop funs chan = do
           (J.uriToFilePath doc)
           (Just 0)
 
+      -- ReqDefinition req -> do
+
+
       _ -> U.logs "unknown msg"
 
 

tools/lsp/squirrel/src/AST.hs

@@ -7,3 +7,4 @@ module AST (module M) where
 import AST.Types  as M
 import AST.Parser as M
 import AST.Scope  as M
+import AST.Find   as M

tools/lsp/squirrel/src/AST/Find.hs

@@ -0,0 +1,55 @@
+
+module AST.Find where
+
+import Control.Monad
+
+import AST.Types
+import AST.Scope
+
+import Tree
+import Range
+import Lattice
+
+import Debug.Trace
+
+findScopedDecl
+  :: ( HasEnv info
+     , HasRange info
+     )
+  => Range
+  -> Pascal info
+  -> Maybe ScopedDecl
+findScopedDecl pos tree = do
+  point <- lookupTree (\info -> pos <? getRange info) tree
+  let env = getEnv (infoOf point)
+  lookupEnv (void point) env
+
+definitionOf
+  :: ( HasEnv info
+     , HasRange info
+     )
+  => Range
+  -> Pascal info
+  -> Maybe Range
+definitionOf pos tree =
+  _sdOrigin <$> findScopedDecl pos tree
+
+typeOf
+  :: ( HasEnv info
+     , HasRange info
+     )
+  => Range
+  -> Pascal info
+  -> Maybe (Either (Pascal ()) Kind)
+typeOf pos tree =
+  _sdType =<< findScopedDecl pos tree
+
+implementationOf
+  :: ( HasEnv info
+     , HasRange info
+     )
+  => Range
+  -> Pascal info
+  -> Maybe Range
+implementationOf pos tree =
+  _sdBody =<< findScopedDecl pos tree

tools/lsp/squirrel/src/AST/Parser.hs

@@ -846,7 +846,7 @@ typeTuple = do
 -- example = "../../../src/test/contracts/amount.ligo"
 -- example = "../../../src/test/contracts/annotation.ligo"
 -- example = "../../../src/test/contracts/arithmetic.ligo"
--- example = "../../../src/test/contracts/assign.ligo"
+example = "../../../src/test/contracts/assign.ligo"
 -- example = "../../../src/test/contracts/attributes.ligo"
 -- example = "../../../src/test/contracts/bad_timestamp.ligo"
 -- example = "../../../src/test/contracts/bad_type_operator.ligo"
@@ -858,7 +858,7 @@ typeTuple = do
 -- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
 -- example = "../../../src/test/contracts/bytes_unpack.ligo"
 -- example = "../../../src/test/contracts/chain_id.ligo"
-example = "../../../src/test/contracts/coase.ligo"
+-- example = "../../../src/test/contracts/coase.ligo"
 -- example = "../../../src/test/contracts/failwith.ligo"
 -- example = "../../../src/test/contracts/loop.ligo"
 -- example = "../../../src/test/contracts/application.ligo"

tools/lsp/squirrel/src/AST/Scope.hs

@@ -6,11 +6,14 @@ module AST.Scope
   ( -- * Monad
     ScopeM
   , evalScopeM
+  , pinEnv
 
     -- * Scope
   , Env(..)
   , ScopedDecl(..)
   , Kind(..)
+  , HasEnv(..)
+  , lookupEnv
 
     -- * Methods
   , enter
@@ -25,12 +28,12 @@ import Control.Monad.State
 
 import Data.Text (Text)
 
-import Parser
 import Range
 import AST.Types
 import Tree
 import Comment
 import Pretty
+import Product
 
 -- | Scope-holding monad.
 type ScopeM = State [Env]
@@ -44,6 +47,10 @@ newtype Env = Env
   { _eDecls :: [ScopedDecl]
   }
   deriving newtype (Semigroup, Monoid)
+  deriving Show via PP Env
+
+instance Pretty Env where
+  pp = vcat . map pp . _eDecls
 
 -- | The type/value declaration.
 data ScopedDecl = ScopedDecl
@@ -53,8 +60,23 @@ data ScopedDecl = ScopedDecl
   , _sdType   :: Maybe (Either (Pascal ()) Kind)
   }
 
+instance Pretty ScopedDecl where
+  pp (ScopedDecl n o b t) = pp o <+> "-" <+> (pp n <> ":") <+> maybe "?" (either pp pp) t <+> "=" <+> pp o
+
 -- | The kind.
 data Kind = Star
+  deriving Show via PP Kind
+
+instance Pretty Kind where
+  pp _ = "*"
+
+lookupEnv :: Pascal () -> Env -> Maybe ScopedDecl
+lookupEnv name = go . _eDecls
+  where
+    go (sd@(ScopedDecl {_sdName}) : rest)
+      | ppToText _sdName == ppToText name = Just sd
+      | otherwise       = go rest
+    go _ = Nothing
 
 -- | Make a new scope out of enclosing parent one.
 enter  :: ScopeM ()
@@ -93,24 +115,11 @@ def name ty body = do
 
 instance UpdateOver ScopeM Contract (Pascal a)
 
--- data Contract it
---   = Contract      [it]
---   deriving (Show) via PP (Contract it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance HasRange a => UpdateOver ScopeM Declaration (Pascal a) where
   before = \case
     TypeDecl ty body -> defType ty Star body
     _ -> skip
 
--- 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)
-
 instance HasRange a => UpdateOver ScopeM Binding (Pascal a) where
   before = \case
     Function recur name _args ty body -> do
@@ -129,56 +138,14 @@ instance HasRange a => UpdateOver ScopeM Binding (Pascal a) where
       unless recur do
         def name (Just ty) (Just body)
 
--- 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)
-
 instance HasRange a => UpdateOver ScopeM VarDecl (Pascal a) where
   after  (Decl _ name ty) = def name (Just ty) Nothing
 
--- data VarDecl it
---   = Decl         it it it -- (Mutable) (Name) (Type)
---   deriving (Show) via PP (VarDecl it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM Mutable (Pascal a)
-
--- data Mutable it
---   = Mutable
---   | Immutable
---   deriving (Show) via PP (Mutable it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM Type    (Pascal a)
-
--- 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)
-
 instance UpdateOver ScopeM Variant (Pascal a)
-
--- data Variant it
---   = Variant it (Maybe it) -- (Name) (Maybe (Type))
---   deriving (Show) via PP (Variant it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM TField  (Pascal a)
 
--- data TField it
---   = TField it it -- (Name) (Type)
---   deriving (Show) via PP (TField it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance HasRange a => UpdateOver ScopeM Expr (Pascal a) where
   before = \case
     Let    {} -> enter
@@ -201,139 +168,38 @@ instance HasRange a => UpdateOver ScopeM Expr (Pascal a) where
     ForBox  {} -> leave
     _ -> skip
 
--- -- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls.
--- 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)
-
 instance HasRange a => UpdateOver ScopeM Alt (Pascal a) where
   before _ = enter
   after  _ = leave
 
--- data Alt it
---   = Alt it it -- (Pattern) (Expr)
---   deriving (Show) via PP (Alt it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM LHS             (Pascal a)
-
--- data LHS it
---   = LHS it (Maybe it) -- (QualifiedName) (Maybe (Expr))
---   deriving (Show) via PP (LHS it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM MapBinding      (Pascal a)
-
--- data MapBinding it
---   = MapBinding it it -- (Expr) (Expr)
---   deriving (Show) via PP (MapBinding it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM Assignment      (Pascal a)
-
--- data Assignment it
---   = Assignment it it -- (Name) (Expr)
---   deriving (Show) via PP (Assignment it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM FieldAssignment (Pascal a)
-
--- data FieldAssignment it
---   = FieldAssignment it it -- (QualifiedName) (Expr)
---   deriving (Show) via PP (FieldAssignment it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM Constant        (Pascal a)
 
--- 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)
-
 instance HasRange a => UpdateOver ScopeM Pattern (Pascal a) where
   before = \case
     IsVar n -> def n Nothing Nothing
     _       -> skip
 
--- 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)
-
 instance UpdateOver ScopeM QualifiedName (Pascal a)
-
--- data QualifiedName it
---   = QualifiedName
---     { qnSource :: it -- Name
---     , qnPath   :: [it] -- [Path]
---     }
---   deriving (Show) via PP (QualifiedName it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM Path          (Pascal a)
-
--- data Path it
---   = At it -- (Name)
---   | Ix Text
---   deriving (Show) via PP (Path it)
---   deriving stock (Functor, Foldable, Traversable)
-
 instance UpdateOver ScopeM Name          (Pascal a)
 
--- data Name it = Name
+class HasEnv a where
---   { _raw     :: Text
+  getEnv :: a -> Env
---   }
+
---   deriving (Show) via PP (Name it)
+instance HasEnv Env where
---   deriving stock (Functor, Foldable, Traversable)
+  getEnv = id
+
+instance Contains Env xs => HasEnv (Product xs) where
+  getEnv = getElem
 
 data Scope = Scope { unScope :: [Text] }
 
 instance HasComments Scope where
   getComments = unScope
 
-currentScope :: ASTInfo -> ScopeM Scope
+pinEnv :: Product xs -> ScopeM (Product (Env : xs))
-currentScope _ = do
+pinEnv xs = (`Cons` xs) <$> gets head
-  Env topmost <- gets head
-  let names = _sdName <$> topmost
-  let res   = map ppToText names
-  return $ Scope res

tools/lsp/squirrel/src/Comment.hs

@@ -9,8 +9,10 @@ module Comment
   where
 
 import qualified Data.Text as Text
+import           Data.Text   (Text)
 
 import Pretty
+import Product
 
 -- | Ability to contain comments.
 class HasComments c where
@@ -31,3 +33,6 @@ c i d =
 -- | Narrator: /But there was none/.
 instance HasComments () where
   getComments () = []
+
+instance (Contains [Text] xs) => HasComments (Product xs) where
+  getComments = getElem

tools/lsp/squirrel/src/Error.hs

@@ -21,7 +21,7 @@ data Error info
     , eInfo  :: info   -- ^ Location of the error.
     }
   deriving (Show) via PP (Error info)
-  deriving stock (Functor, Foldable, Traversable)
+  deriving stock (Eq, Functor, Foldable, Traversable)
 
 instance Pretty1 Error where
   pp1 (Expected msg found r) = "░" <> pp msg <> r <> "▒" <> pp found <> "▓"

tools/lsp/squirrel/src/Parser.hs

@@ -64,7 +64,7 @@ module Parser
   ) where
 
 import Control.Monad.State
-import Control.Monad.Writer
+import Control.Monad.Writer hiding (Product)
 import Control.Monad.Except
 import Control.Monad.Identity
 
@@ -78,6 +78,7 @@ import Range
 import Pretty
 import Comment
 import Error
+import Product
 
 import Debug.Trace
 
@@ -218,7 +219,7 @@ die' msg rng = throwError =<< makeError' msg rng
 -- | When tree-sitter found something it was unable to process.
 unexpected :: ParseTree -> Error ASTInfo
 unexpected ParseTree { ptSource, ptRange } =
-  Expected "not that" ptSource (ASTInfo ptRange [])
+  Expected "not that" ptSource (Cons ptRange $ Cons [] Nil)
 
 -- | If a parser fails, return stub with error originating here.
 stubbed :: Stubbed a ASTInfo => Text -> Parser a -> Parser a
@@ -324,7 +325,7 @@ anything = do
 range :: Parser a -> Parser (a, Range)
 range parser =
   get >>= \case
-    (,) Forest {pfGrove = (,) _ ParseTree {ptRange} : _} _ -> do
+    (,) Forest {pfGrove = [(,) _ ParseTree {ptRange}]} _ -> do
       a <- parser
       return (a, ptRange)
 
@@ -398,23 +399,11 @@ inside sig parser = do
             parser
 
 -- | Auto-accumulated information to be put into AST being build.
-data ASTInfo = ASTInfo
+type ASTInfo = Product [Range, [Text]]
-  { aiRange    :: Range
-  , aiComments :: [Text]
-  }
-
-instance Pretty ASTInfo where
-  pp (ASTInfo r comms) = pp r $$ vcat (map (text . unpack) comms)
-
-instance HasComments ASTInfo where
-  getComments = aiComments
-
-instance HasRange ASTInfo where
-  getRange = aiRange
 
 -- | Equip given constructor with info.
 getInfo :: Parser ASTInfo
-getInfo = ASTInfo <$> currentRange <*> grabComments
+getInfo = Cons <$> currentRange <*> do Cons <$> grabComments <*> pure Nil
 
 -- | Take the accumulated comments, clean the accumulator.
 grabComments :: Parser [Text]

tools/lsp/squirrel/src/Pretty.hs

@@ -66,6 +66,9 @@ instance Pretty () where
 instance (Pretty1 p, Functor p, Pretty a) => Pretty (p a) where
   pp = pp1 . fmap pp
 
+instance Pretty1 [] where
+  pp1 = list
+
 -- | Common instance.
 instance Pretty Text where
   pp = text . Text.unpack

tools/lsp/squirrel/src/Product.hs

@@ -0,0 +1,32 @@
+
+module Product where
+
+import Pretty
+
+data Product xs where
+  Nil  :: Product '[]
+  Cons :: { pHead :: x, pTail :: Product xs } -> Product (x : xs)
+
+instance Pretty (Product xs) => Show (Product xs) where
+  show = show . PP
+
+class Contains x xs where
+  getElem :: Product xs -> x
+  putElem :: x -> Product xs -> Product xs
+
+instance {-# OVERLAPS #-} Contains x (x : xs) where
+  getElem   (Cons x _)  = x
+  putElem x (Cons _ xs) = Cons x xs
+
+instance Contains x xs => Contains x (y : xs) where
+  getElem   (Cons _ xs) = getElem xs
+  putElem x (Cons y xs) = Cons y (putElem x xs)
+
+modifyElem :: Contains x xs => (x -> x) -> Product xs -> Product xs
+modifyElem f xs = putElem (f $ getElem xs) xs
+
+instance Pretty (Product '[]) where
+  pp _ = "{}"
+
+instance (Pretty x, Pretty (Product xs)) => Pretty (Product (x : xs)) where
+  pp (Cons x xs) = pp x <+> "&" <+> pp xs

tools/lsp/squirrel/src/Range.hs

@@ -16,6 +16,8 @@ import Data.Text (Text)
 import Data.Text.Encoding
 
 import Pretty
+import Lattice
+import Product
 
 -- | A continious location in text.
 data Range = Range
@@ -37,6 +39,9 @@ instance Pretty Range where
 class HasRange a where
   getRange :: a -> Range
 
+instance Contains Range xs => HasRange (Product xs) where
+  getRange = getElem
+
 -- | Extract textual representation of given range.
 cutOut :: Range -> ByteString -> Text
 cutOut (Range (_, _, s) (_, _, f)) bs =
@@ -45,3 +50,7 @@ cutOut (Range (_, _, s) (_, _, f)) bs =
     $ BS.drop  s
       bs
 
+instance Lattice Range where
+  Range (ll1, lc1, _) (ll2, lc2, _) <? Range (rl1, rc1, _) (rl2, rc2, _) =
+    (rl1 < ll1 || rl1 == ll1 && rc1 <= lc1) &&
+    (rl2 > ll2 || rl2 == ll2 && rc2 >= lc2)

tools/lsp/squirrel/src/Tree.hs

@@ -12,7 +12,7 @@
 module Tree
   ( -- * Tree type
     Tree
-  , spineTo
+  , lookupTree
   , traverseTree
   , mk
   , infoOf
@@ -23,13 +23,18 @@ module Tree
   )
   where
 
+import Data.Foldable
+import Data.List
 import Data.Sum
+import Data.Monoid (First(..), getFirst)
 
 import Lattice
 import Comment
 import Pretty
 import Error
 
+import Debug.Trace
+
 -- | A tree, where each layer is one of @layers@ `Functor`s.
 --
 --   Is equipped with @info@.
@@ -40,6 +45,16 @@ newtype Tree layers info = Tree
   { unTree :: Either (Error info) (info, Sum layers (Tree layers info))
   }
 
+dumpTree
+  :: (Apply Functor layers, Apply Foldable layers, HasComments info, Pretty1 (Sum layers), Pretty info)
+  => Tree layers info
+  -> Doc
+dumpTree (Tree tree) =
+  case tree of
+    Left e -> "ERR"
+    Right (i, ls) ->
+      pp (Tree tree) `indent` block (dumpTree <$> toList ls)
+
 instance Apply Functor layers => Functor (Tree layers) where
   fmap f = go
     where
@@ -78,22 +93,24 @@ instance {-# OVERLAPS #-}
         go (Tree (Right (info, fTree))) = c info $ pp fTree
 
 -- | Return all subtrees that cover the range, ascending in size.
-spineTo
+lookupTree
-  :: ( Lattice   info
+  :: forall fs info
-     , Apply Foldable fs
+  .  ( Apply Foldable fs
+     , Apply Functor fs
      )
-  => info
+  => (info -> Bool)
   -> Tree fs info
-  -> [Tree fs info]
+  -> Maybe (Tree fs info)
-spineTo info = reverse . go
+lookupTree rightInfo = go
   where
-    go tree@(Tree (Right (info', fres))) =
+    go :: Tree fs info -> Maybe (Tree fs info)
-      if   info <? info'
+    go tree = do
-      then tree : foldMap go fres
+      if rightInfo (infoOf tree)
-      else []
+      then getFirst $ foldMap (First . go) (layers tree) <> First (Just tree)
-
+      else Nothing
-    go _ = []
 
+    layers :: (Apply Foldable fs) => Tree fs info -> [Tree fs info]
+    layers (Tree (Right (_, ls))) = toList ls
 -- | Traverse the tree over some monad that exports its methods.
 --
 --   For each tree piece, will call `before` and `after` callbacks.