Remove warnings, refactor FullEnv

src/test/contracts/blocks.ligo

@@ -0,0 +1,7 @@
+
+function main() : int is
+  block
+    var j := 1;
+    j := j + 1;
+    j := j - 1;
+  with j

tools/lsp/squirrel/app/Main.hs

@@ -6,9 +6,9 @@ import           Control.Lens
 import           Control.Monad
 
 import           Data.Default
+-- import           Data.Foldable
 import qualified Data.Text                             as Text
 import           Data.Text                               (Text)
-import           Data.Foldable
 import           Data.String.Interpolate (i)
 
 import qualified Language.Haskell.LSP.Control          as CTRL
@@ -214,6 +214,8 @@ loadByURI uri = do
     Just fin -> do
       (tree, _) <- runParser contract (Path fin)
       return $ addLocalScopes tree
+    Nothing -> do
+      error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed."
 
 collectErrors
   :: Core.LspFuncs ()

tools/lsp/squirrel/package.yaml

@@ -5,9 +5,10 @@ dependencies:
   - bytestring
   - containers
   - data-default
-  - filepath
   - exceptions
   - fastsum
+  - filepath
+  - ghc-prim
   - mtl
   - pretty
   - text

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

@@ -7,14 +7,12 @@ import AST.Types
 import AST.Scope
 import AST.Parser
 
-import Parser
 import Tree
 import Range
-import Lattice
 import Pretty
 import Product
 
-import Debug.Trace
+-- import Debug.Trace
 
 findScopedDecl
   :: ( Contains [ScopedDecl] xs
@@ -25,13 +23,13 @@ findScopedDecl
   -> Pascal (Product xs)
   -> Maybe ScopedDecl
 findScopedDecl pos tree = do
-  point <- lookupTree pos tree
+  pt <- lookupTree pos tree
-  let info = infoOf point
+  let info = infoOf pt
   let fullEnv = getElem info
   do
-    cat <- getElem info
+    categ <- getElem info
-    let filtered = filter (ofCategory cat) fullEnv
+    let filtered = filter (ofCategory categ) fullEnv
-    lookupEnv (ppToText $ void point) filtered
+    lookupEnv (ppToText $ void pt) filtered
 
 definitionOf
   :: ( Contains [ScopedDecl] xs

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

@@ -2,11 +2,11 @@
 {- | Parser for a contract.
 -}
 
-module AST.Parser (example, contract) where
+module AST.Parser (example, contract, sample) where
 
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Data.Sum
+import Data.Sum (Element)
 
 import AST.Types
 
@@ -892,7 +892,10 @@ typeTuple = do
   subtree "type_tuple" do
     many do inside "element" type_
 
--- example :: Text
+sample :: IO (Pascal ASTInfo)
+sample = runParser' contract (Path example)
+
+example :: FilePath
 -- example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/address.ligo"
 -- example = "../../../src/test/contracts/amount.ligo"
@@ -915,7 +918,7 @@ typeTuple = do
 -- example = "../../../src/test/contracts/loop.ligo"
 -- example = "../../../src/test/contracts/redeclaration.ligo"
 -- example = "../../../src/test/contracts/includer.ligo"
-example = "../../../src/test/contracts/namespaces.ligo"
+-- example = "../../../src/test/contracts/namespaces.ligo"
--- example = "../../../src/test/contracts/application.ligo"
+example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/application.ligo"

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

@@ -15,56 +15,58 @@ module AST.Scope
 
 import           Control.Arrow (second)
 import           Control.Monad.State
-import           Control.Monad.Writer.Strict hiding (Alt, Product)
 
-import           Data.Function
 import qualified Data.List   as List
-import           Data.Map      (Map)
+import           Data.Map            (Map)
 import qualified Data.Map    as Map
-import           Data.Maybe    (fromJust, listToMaybe)
+import           Data.Maybe          (listToMaybe)
-import           Data.Text     (Text)
+import           Data.Sum            (Element, Apply, Sum)
-import qualified Data.Text   as Text
+import           Data.Text           (Text)
 
-import           AST.Parser
+-- import           AST.Parser
 import           AST.Types
-import           Comment
+-- import           Comment
 import           Lattice
-import           Parser
+-- import           Parser
 import           Pretty
 import           Product
 import           Range
 import           Tree
 
-import           Debug.Trace
+-- import           Debug.Trace
-
--- | Ability to contain a list of declarations.
-class HasLocalScope x where
-  getLocalScope :: x -> [ScopedDecl]
-
-instance Contains [ScopedDecl] xs => HasLocalScope (Product xs) where
-  getLocalScope = getElem
 
 type CollectM = State (Product [FullEnv, [Range]])
 
-type AddRefsM = State FullEnv
+type FullEnv = Product ["vars" := Env, "types" := Env]
-
+type Env     = Map Range [ScopedDecl]
-data FullEnv = FullEnv
-  { vars   :: Env
-  , types  :: Env
-  }
 
 data Category = Variable | Type
 
-emptyEnv = FullEnv Map.empty Map.empty
+-- | The type/value declaration.
+data ScopedDecl = ScopedDecl
+  { _sdName    :: Pascal ()
+  , _sdOrigin  :: Range
+  , _sdBody    :: Maybe Range
+  , _sdType    :: Maybe (Either (Pascal ()) Kind)
+  , _sdRefs    :: [Range]
+  }
+  deriving Show via PP ScopedDecl
 
-with Variable (FullEnv vs ts) f = FullEnv (f vs) ts
+-- | The kind.
-with Type     (FullEnv vs ts) f = FullEnv vs (f ts)
+data Kind = Star
+  deriving Show via PP Kind
 
-grab Variable (FullEnv vs ts) = vs
+emptyEnv :: FullEnv
-grab Type     (FullEnv vs ts) = ts
+emptyEnv
+  = Cons (Tag Map.empty)
+  $ Cons (Tag Map.empty)
+    Nil
 
-type Env = Map Range [ScopedDecl]
+with :: Category -> FullEnv -> (Env -> Env) -> FullEnv
+with Variable env f = modTag @"vars"  f env
+with Type     env f = modTag @"types" f env
 
+ofCategory :: Category -> ScopedDecl -> Bool
 ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False
 ofCategory Variable _                                          = True
 ofCategory Type     ScopedDecl { _sdType = Just (Right Star) } = True
@@ -100,6 +102,17 @@ addNameCategories tree = flip evalState emptyEnv do
     (Cons Nothing)
     tree
 
+getEnvTree
+  :: ( UpdateOver CollectM (Sum fs) (Tree fs b)
+     , 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
@@ -120,7 +133,7 @@ getEnvTree tree = envWithREfs
       $ traverseTree pure tree
 
 fullEnvAt :: FullEnv -> Range -> [ScopedDecl]
-fullEnvAt fe r = envAt (grab Type fe) r <> envAt (grab Variable fe) r
+fullEnvAt fe r = envAt (getTag @"types" fe) r <> envAt (getTag @"vars" fe) r
 
 envAt :: Env -> Range -> [ScopedDecl]
 envAt env pos =
@@ -133,8 +146,8 @@ envAt env pos =
     toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd
 
 addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv
-addRef r (cat, n) env =
+addRef r (categ, n) env =
-  with cat env \slice ->
+  with categ env \slice ->
     Map.union
       (go slice $ range slice)
       slice
@@ -143,8 +156,8 @@ addRef r (cat, n) env =
       let decls = slice Map.! r'
       in
         case updateOnly n r addRefToDecl decls of
-          (True,  decls) -> Map.singleton r' decls
+          (True,  decls') -> Map.singleton r' decls'
-          (False, decls) -> Map.insert r' decls (go slice rest)
+          (False, decls') -> Map.insert    r' decls' (go slice rest)
     go _ [] = Map.empty
 
     range slice
@@ -179,11 +192,11 @@ enter r = do
   modify $ modElem (r :)
 
 define :: Category -> ScopedDecl -> CollectM ()
-define cat sd = do
+define categ sd = do
-  r <- gets (head . getElem)
+  r <- gets (head . getElem @[Range])
   modify
     $ modElem @FullEnv \env ->
-        with cat env
+        with categ env
         $ Map.insertWith (++) r [sd]
 
 leave :: CollectM ()
@@ -199,24 +212,10 @@ instance {-# OVERLAPS #-} Pretty FullEnv where
       aux (r, fe) =
         pp r `indent` block fe
 
-      mergeFE (FullEnv a b) = a <> b
+      mergeFE fe = getTag @"vars" @Env fe <> getTag @"types" fe
-
--- | The type/value declaration.
-data ScopedDecl = ScopedDecl
-  { _sdName    :: Pascal ()
-  , _sdOrigin  :: Range
-  , _sdBody    :: Maybe Range
-  , _sdType    :: Maybe (Either (Pascal ()) Kind)
-  , _sdRefs    :: [Range]
-  }
-  deriving Show via PP ScopedDecl
 
 instance Pretty ScopedDecl where
-  pp (ScopedDecl n o b t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs
+  pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs
-
--- | The kind.
-data Kind = Star
-  deriving Show via PP Kind
 
 instance Pretty Kind where
   pp _ = "TYPE"

tools/lsp/squirrel/src/Lattice.hs

@@ -22,5 +22,5 @@ partOrder :: Lattice l => l -> l -> Ordering
 partOrder a b | a <? b && b <? a = EQ
 partOrder a b | a <? b           = LT
 partOrder a b |           b <? a = GT
-partOrder a b                    = error "partOrder: Non-orderable"
+partOrder _ _                    = error "partOrder: Non-orderable"
 

tools/lsp/squirrel/src/Parser.hs

@@ -62,7 +62,7 @@ module Parser
   , dump
 
     -- * Comments and ranges
-  , ASTInfo(..)
+  , ASTInfo
   , Source(..)
   , module ParseTree
   ) where
@@ -74,8 +74,7 @@ import qualified Control.Monad.Reader as MTL
 
 import Data.Functor ((<&>))
 import Data.Foldable
-import Data.IORef
+import Data.Text (Text)
-import Data.Text (Text, unpack)
 import qualified Data.Text as Text
 import qualified Data.Set as Set
 
@@ -84,7 +83,6 @@ import System.FilePath
 import ParseTree
 import Range
 import Pretty
-import Comment
 import Error
 import Product
 
@@ -289,7 +287,7 @@ subtree msg parser = do
 l <|> r = do
   s <- get' @ParseForest
   c <- get' @[Text]
-  l `catch` \(e :: Error ASTInfo) -> do
+  l `catch` \(_ :: Error ASTInfo) -> do
     put' s
     put' c
     r

tools/lsp/squirrel/src/Product.hs

@@ -4,6 +4,8 @@
 
 module Product where
 
+import GHC.Types
+
 -- | `Product xs` contains elements of each of the types from the `xs` list.
 data Product xs where
   Cons :: x -> Product xs -> Product (x : xs)
@@ -27,7 +29,7 @@ instance Contains x xs => Contains x (y : xs) where
 
 -- | Add a name to the type.
 --
-newtype (s :: String) := t = Tag { unTag :: t }
+newtype (s :: Symbol) := t = Tag { unTag :: t }
 
 -- | Retrieve a type associated with the given name.
 --

tools/lsp/squirrel/src/Range.hs

@@ -16,8 +16,6 @@ import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Text.Encoding
 
-import System.FilePath
-
 import Pretty
 import Lattice
 import Product

tools/lsp/squirrel/src/Tree.hs

@@ -24,7 +24,7 @@ module Tree
   where
 
 import Data.Foldable
-import Data.List
+-- import Data.List
 import Data.Sum
 import Data.Monoid (First(..), getFirst)
 
@@ -34,7 +34,7 @@ import Pretty
 import Error
 import Range
 
-import Debug.Trace
+-- import Debug.Trace
 
 -- | A tree, where each layer is one of @layers@ `Functor`s.
 --
@@ -52,8 +52,8 @@ dumpTree
   -> Doc
 dumpTree (Tree tree) =
   case tree of
-    Left e -> "ERR"
+    Left _ -> "ERR"
-    Right (i, ls) ->
+    Right (_, ls) ->
       pp (Tree tree) `indent` block (dumpTree <$> toList ls)
 
 instance Apply Functor layers => Functor (Tree layers) where
@@ -129,6 +129,7 @@ lookupTree target = go
 
     layers :: (Apply Foldable fs) => Tree fs info -> [Tree fs info]
     layers (Tree (Right (_, ls))) = toList ls
+    layers  _                     = []
 
 -- | Traverse the tree over some monad that exports its methods.
 --