diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 4124f380f..d6a7a9f87 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -24,6 +24,8 @@ import Language.Haskell.LSP.VFS import System.Exit import qualified System.Log as L +import Duplo.Pretty + import Parser import ParseTree import Range @@ -36,7 +38,7 @@ main :: IO () main = do return () for_ [1.. 100] \_ -> do - print . length . show =<< sample' "../../../src/test/contracts/loop.ligo" + print . length . show . pp =<< sample' "../../../src/test/contracts/loop.ligo" -- errCode <- mainLoop -- exit errCode diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index a56329d00..aa4cc156b 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -47,11 +47,11 @@ import Debug.Trace -- example = "../../../src/test/contracts/chain_id.ligo" example = "../../../src/test/contracts/closure-3.ligo" -sample' :: FilePath -> IO Doc +sample' :: FilePath -> IO (LIGO Info) sample' f = toParseTree (Path f) >>= runParserM . recognise - >>= return . pp . fst + >>= return . fst source' :: FilePath -> IO () source' f @@ -70,7 +70,7 @@ source >>= print . pp recognise :: RawTree -> ParserM (LIGO Info) -recognise = descent (error . show . pp . fst) $ map usingScope +recognise = descent (\_ -> error . show . pp) $ map usingScope [ -- Contract Descent [ boilerplate \case diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 34ae13b58..67ef19116 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -13,7 +13,7 @@ module AST.Scope -- ) where -import Control.Arrow (second) +import Control.Arrow (first, second) import Control.Monad.State import qualified Data.List as List @@ -26,11 +26,12 @@ import Data.Text (Text) import Duplo.Lattice import Duplo.Pretty import Duplo.Tree +import Duplo.Error --- import AST.Parser +import AST.Parser import AST.Types -- import Comment --- import Parser +import Parser import Product import Range @@ -42,6 +43,7 @@ type FullEnv = Product ["vars" := Env, "types" := Env] type Env = Map Range [ScopedDecl] data Category = Variable | Type + deriving Eq -- | The type/value declaration. data ScopedDecl = ScopedDecl @@ -88,65 +90,74 @@ ofCategory Variable _ = True ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True ofCategory _ _ = False --- addLocalScopes --- :: Contains Range xs --- => LIGO (Product xs) --- -> LIGO (Product ([ScopedDecl] : Maybe Category : xs)) --- addLocalScopes tree = --- fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1 --- where --- tree1 = addNameCategories tree --- envWithREfs = getEnvTree tree +instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where + ascribe (ds :> _) d = + color 2 (fsep (map (pp . _sdName) ds)) + $$ d --- addNameCategories --- :: Contains Range xs --- => LIGO (Product xs) --- -> LIGO (Product (Maybe Category : xs)) --- addNameCategories tree = flip evalState emptyEnv do --- traverseMany --- [ Visit \r (Name t) -> do --- modify $ getRange r `addRef` (Variable, t) --- return $ (Cons (Just Variable) r, Name t) +addLocalScopes + :: (Contains Range xs, Eq (Product xs)) + => LIGO (Product xs) + -> LIGO (Product ([ScopedDecl] : Maybe Category : xs)) +addLocalScopes tree = + fmap (\xs -> fullEnvAt envWithREfs (getRange xs) :> xs) tree1 + where + tree1 = addNameCategories tree + envWithREfs = getEnvTree tree --- , Visit \r (TypeName t) -> do --- modify $ getRange r `addRef` (Type, t) --- return $ (Cons (Just Type) r, TypeName t) --- ] --- (Cons Nothing) --- tree +addNameCategories + :: (Contains Range xs, Eq (Product xs)) + => LIGO (Product xs) + -> LIGO (Product (Maybe Category : xs)) +addNameCategories tree = flip evalState emptyEnv do + descent (changeInfo (Nothing :>)) + [ Descent + [ \(r, Name t) -> do + -- modify $ getRange r `addRef` (Variable, t) + return $ Just $ (Just Variable :> r, Name t) + ] --- getEnvTree --- :: ( Apply (Scoped b CollectM (Tree fs b)) fs --- , Apply Foldable fs --- , Apply Functor fs --- , Apply Traversable fs --- , HasRange b --- , Element Name fs --- , Element TypeName fs --- ) --- => Tree fs b --- -> FullEnv --- getEnvTree tree = envWithREfs --- where --- envWithREfs = flip execState env do --- descent return --- [ usingScope $ Descent --- [ \(r, Name t) -> do --- modify $ getRange r `addRef` (Variable, t) --- return $ (r, Name t) --- ] + , Descent + [ \(r, TypeName t) -> do + -- modify $ getRange r `addRef` (Type, t) + return $ Just $ (Just Type :> r, TypeName t) + ] + ] + tree --- , usingScope $ Descent --- [ \(r, TypeName t) -> do --- modify $ getRange r `addRef` (Type, t) --- return $ (r, TypeName t) --- ] --- ] --- tree +getEnvTree + :: ( Apply (Scoped b CollectM (Tree fs b)) fs + , Apply Foldable fs + , Apply Functor fs + , Apply Traversable fs + , Lattice b + , HasRange b + , Element Name fs + , Element TypeName fs + ) + => Tree fs b + -> FullEnv +getEnvTree tree = envWithREfs + where + envWithREfs = flip execState env do + descent leaveBe + [ Descent + [ \(r, Name t) -> do + modify $ getRange r `addRef` (Variable, t) + return $ Just (r, Name t) + ] --- env --- = execCollectM --- $ traverseTree pure tree + , Descent + [ \(r, TypeName t) -> do + modify $ getRange r `addRef` (Type, t) + return $ Just (r, TypeName t) + ] + ] + tree + + env + = execCollectM + $ descent (usingScope' leaveBe) [] tree fullEnvAt :: FullEnv -> Range -> [ScopedDecl] fullEnvAt fe r @@ -265,6 +276,10 @@ instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) C before r _ = enter r after _ _ = skip +instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) RawContract where + before r _ = enter r + after _ _ = skip + instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Binding where before r = \case Function recur name _args ty body -> do @@ -335,3 +350,8 @@ instance Scoped a CollectM (LIGO a) Path instance Scoped a CollectM (LIGO a) Name instance Scoped a CollectM (LIGO a) TypeName instance Scoped a CollectM (LIGO a) FieldName + +instance Scoped a CollectM (LIGO a) (Err Text) +instance Scoped a CollectM (LIGO a) Language +instance Scoped a CollectM (LIGO a) Parameters +instance Scoped a CollectM (LIGO a) Ctor \ No newline at end of file diff --git a/tools/lsp/squirrel/stack.yaml b/tools/lsp/squirrel/stack.yaml index 6bf8ab508..59a133b44 100644 --- a/tools/lsp/squirrel/stack.yaml +++ b/tools/lsp/squirrel/stack.yaml @@ -41,7 +41,7 @@ extra-deps: - semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 - fastsum-0.1.1.1 - git: https://github.com/serokell/duplo.git - commit: 325aefe2a0e6c7a6bdd08935be669da308ed0cb1 + commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a diff --git a/tools/lsp/squirrel/stack.yaml.lock b/tools/lsp/squirrel/stack.yaml.lock index a7c3c78dc..ce3b4676d 100644 --- a/tools/lsp/squirrel/stack.yaml.lock +++ b/tools/lsp/squirrel/stack.yaml.lock @@ -45,11 +45,11 @@ packages: git: https://github.com/serokell/duplo.git pantry-tree: size: 557 - sha256: adf7b6a5ae51a4ffa8a8db534bc030fb61209cc0be28c3bf82864267e40346c7 - commit: 325aefe2a0e6c7a6bdd08935be669da308ed0cb1 + sha256: d8258e8fa560d07da3bf4a5e7f956494a8d1b374e67c3af1b7b6875f8175a309 + commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae original: git: https://github.com/serokell/duplo.git - commit: 325aefe2a0e6c7a6bdd08935be669da308ed0cb1 + commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae snapshots: - completed: size: 493124