From 9f124bf5af93b716cc0cf772863512b1ebd71d12 Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Tue, 9 Jun 2020 15:56:11 +0400 Subject: [PATCH] Implement def/impl/type search --- tools/lsp/pascaligo/grammar.js | 2 +- tools/lsp/squirrel/app/Main.hs | 4 + tools/lsp/squirrel/src/AST.hs | 5 +- tools/lsp/squirrel/src/AST/Find.hs | 55 +++++++ tools/lsp/squirrel/src/AST/Parser.hs | 4 +- tools/lsp/squirrel/src/AST/Scope.hs | 212 +++++---------------------- tools/lsp/squirrel/src/Comment.hs | 7 +- tools/lsp/squirrel/src/Error.hs | 2 +- tools/lsp/squirrel/src/Parser.hs | 23 +-- tools/lsp/squirrel/src/Pretty.hs | 3 + tools/lsp/squirrel/src/Product.hs | 32 ++++ tools/lsp/squirrel/src/Range.hs | 9 ++ tools/lsp/squirrel/src/Tree.hs | 43 ++++-- 13 files changed, 191 insertions(+), 210 deletions(-) create mode 100644 tools/lsp/squirrel/src/AST/Find.hs create mode 100644 tools/lsp/squirrel/src/Product.hs diff --git a/tools/lsp/pascaligo/grammar.js b/tools/lsp/pascaligo/grammar.js index fb206f37c..602dbe5e1 100644 --- a/tools/lsp/pascaligo/grammar.js +++ b/tools/lsp/pascaligo/grammar.js @@ -756,6 +756,6 @@ module.exports = grammar({ Unit: $ => 'Unit', None: $ => 'None', skip: $ => 'skip', - recursive: $ => 'recursive', + recursive: $ => 'recursive', } }); \ No newline at end of file diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 03d971244..62a025456 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/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" diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index 887d1f369..a019a7106 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/tools/lsp/squirrel/src/AST.hs @@ -4,6 +4,7 @@ module AST (module M) where -import AST.Types as M +import AST.Types as M import AST.Parser as M -import AST.Scope as M +import AST.Scope as M +import AST.Find as M diff --git a/tools/lsp/squirrel/src/AST/Find.hs b/tools/lsp/squirrel/src/AST/Find.hs new file mode 100644 index 000000000..908c414ad --- /dev/null +++ b/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 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 diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index f81023790..a98a601f6 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/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" diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 2cff318eb..a5a1d292d 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/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,55 +138,13 @@ 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 Type (Pascal a) 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 UpdateOver ScopeM TField (Pascal a) instance HasRange a => UpdateOver ScopeM Expr (Pascal a) where before = \case @@ -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 LHS (Pascal a) +instance UpdateOver ScopeM MapBinding (Pascal a) +instance UpdateOver ScopeM Assignment (Pascal a) 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 UpdateOver ScopeM Constant (Pascal a) 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) +instance UpdateOver ScopeM Path (Pascal a) +instance UpdateOver ScopeM Name (Pascal a) --- data QualifiedName it --- = QualifiedName --- { qnSource :: it -- Name --- , qnPath :: [it] -- [Path] --- } --- deriving (Show) via PP (QualifiedName it) --- deriving stock (Functor, Foldable, Traversable) +class HasEnv a where + getEnv :: a -> Env -instance UpdateOver ScopeM Path (Pascal a) +instance HasEnv Env where + getEnv = id --- 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 --- { _raw :: Text --- } --- deriving (Show) via PP (Name it) --- deriving stock (Functor, Foldable, Traversable) +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 -currentScope _ = do - Env topmost <- gets head - let names = _sdName <$> topmost - let res = map ppToText names - return $ Scope res \ No newline at end of file +pinEnv :: Product xs -> ScopeM (Product (Env : xs)) +pinEnv xs = (`Cons` xs) <$> gets head \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Comment.hs b/tools/lsp/squirrel/src/Comment.hs index d55bd03be..2c7c9d863 100644 --- a/tools/lsp/squirrel/src/Comment.hs +++ b/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 @@ -30,4 +32,7 @@ c i d = -- | Narrator: /But there was none/. instance HasComments () where - getComments () = [] \ No newline at end of file + getComments () = [] + +instance (Contains [Text] xs) => HasComments (Product xs) where + getComments = getElem diff --git a/tools/lsp/squirrel/src/Error.hs b/tools/lsp/squirrel/src/Error.hs index 72a32c84b..8daf90e75 100644 --- a/tools/lsp/squirrel/src/Error.hs +++ b/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 <> "▓" diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index b9c60e16e..91c52b7ee 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/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 - { 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 +type ASTInfo = Product [Range, [Text]] -- | 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] diff --git a/tools/lsp/squirrel/src/Pretty.hs b/tools/lsp/squirrel/src/Pretty.hs index f0abd7719..9936a1f22 100644 --- a/tools/lsp/squirrel/src/Pretty.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/Product.hs b/tools/lsp/squirrel/src/Product.hs new file mode 100644 index 000000000..f5faf5ac5 --- /dev/null +++ b/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 diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index 28017485b..5981826a2 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/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, _) ll2 || rl2 == ll2 && rc2 >= lc2) diff --git a/tools/lsp/squirrel/src/Tree.hs b/tools/lsp/squirrel/src/Tree.hs index ae18e608b..6cb9b2810 100644 --- a/tools/lsp/squirrel/src/Tree.hs +++ b/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 - :: ( Lattice info - , Apply Foldable fs +lookupTree + :: forall fs info + . ( Apply Foldable fs + , Apply Functor fs ) - => info + => (info -> Bool) -> Tree fs info - -> [Tree fs info] -spineTo info = reverse . go + -> Maybe (Tree fs info) +lookupTree rightInfo = go where - go tree@(Tree (Right (info', fres))) = - if info Maybe (Tree fs info) + go tree = do + if rightInfo (infoOf tree) + then getFirst $ foldMap (First . go) (layers tree) <> First (Just tree) + else Nothing + 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.