Update AST.Scope to new framework

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
 

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

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

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

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