From 20014a7926cea31a47efddb15e16cc80f6f47ad1 Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Fri, 10 Jul 2020 15:11:49 +0400 Subject: [PATCH] Remove warnings, refactor FullEnv --- src/test/contracts/blocks.ligo | 7 ++ tools/lsp/squirrel/app/Main.hs | 4 +- tools/lsp/squirrel/package.yaml | 3 +- tools/lsp/squirrel/src/AST/Find.hs | 14 ++-- tools/lsp/squirrel/src/AST/Parser.hs | 13 ++-- tools/lsp/squirrel/src/AST/Scope.hs | 105 +++++++++++++-------------- tools/lsp/squirrel/src/Lattice.hs | 2 +- tools/lsp/squirrel/src/Parser.hs | 8 +- tools/lsp/squirrel/src/Product.hs | 4 +- tools/lsp/squirrel/src/Range.hs | 2 - tools/lsp/squirrel/src/Tree.hs | 9 ++- 11 files changed, 90 insertions(+), 81 deletions(-) create mode 100644 src/test/contracts/blocks.ligo diff --git a/src/test/contracts/blocks.ligo b/src/test/contracts/blocks.ligo new file mode 100644 index 000000000..74243006b --- /dev/null +++ b/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 \ No newline at end of file diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 92beb87c4..2e256c2c1 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/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 () diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index e45d3e35c..e24f8777e 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -5,9 +5,10 @@ dependencies: - bytestring - containers - data-default - - filepath - exceptions - fastsum + - filepath + - ghc-prim - mtl - pretty - text diff --git a/tools/lsp/squirrel/src/AST/Find.hs b/tools/lsp/squirrel/src/AST/Find.hs index 5bf449178..7fe815c68 100644 --- a/tools/lsp/squirrel/src/AST/Find.hs +++ b/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 - let info = infoOf point + pt <- lookupTree pos tree + let info = infoOf pt let fullEnv = getElem info do - cat <- getElem info - let filtered = filter (ofCategory cat) fullEnv - lookupEnv (ppToText $ void point) filtered + categ <- getElem info + let filtered = filter (ofCategory categ) fullEnv + lookupEnv (ppToText $ void pt) filtered definitionOf :: ( Contains [ScopedDecl] xs diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index e50423ea6..3600baa46 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/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/application.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" diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 920760736..58ca29b0c 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/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.Text (Text) -import qualified Data.Text as Text +import Data.Maybe (listToMaybe) +import Data.Sum (Element, Apply, Sum) +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 - --- | Ability to contain a list of declarations. -class HasLocalScope x where - getLocalScope :: x -> [ScopedDecl] - -instance Contains [ScopedDecl] xs => HasLocalScope (Product xs) where - getLocalScope = getElem +-- import Debug.Trace type CollectM = State (Product [FullEnv, [Range]]) -type AddRefsM = State FullEnv - -data FullEnv = FullEnv - { vars :: Env - , types :: Env - } +type FullEnv = Product ["vars" := Env, "types" := Env] +type Env = Map Range [ScopedDecl] 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 -with Type (FullEnv vs ts) f = FullEnv vs (f ts) +-- | The kind. +data Kind = Star + deriving Show via PP Kind -grab Variable (FullEnv vs ts) = vs -grab Type (FullEnv vs ts) = ts +emptyEnv :: FullEnv +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 = - with cat env \slice -> +addRef r (categ, n) env = + 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 - (False, decls) -> Map.insert r' decls (go slice rest) + (True, decls') -> Map.singleton r' decls' + (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 - r <- gets (head . getElem) +define categ sd = do + 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 - --- | 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 + mergeFE fe = getTag @"vars" @Env fe <> getTag @"types" fe 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 - --- | The kind. -data Kind = Star - deriving Show via PP Kind + pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs instance Pretty Kind where pp _ = "TYPE" diff --git a/tools/lsp/squirrel/src/Lattice.hs b/tools/lsp/squirrel/src/Lattice.hs index c9cb4b313..feff2dc18 100644 --- a/tools/lsp/squirrel/src/Lattice.hs +++ b/tools/lsp/squirrel/src/Lattice.hs @@ -22,5 +22,5 @@ partOrder :: Lattice l => l -> l -> Ordering partOrder a b | a )) import Data.Foldable -import Data.IORef -import Data.Text (Text, unpack) +import Data.Text (Text) 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 diff --git a/tools/lsp/squirrel/src/Product.hs b/tools/lsp/squirrel/src/Product.hs index ed69c63c4..917b03b1d 100644 --- a/tools/lsp/squirrel/src/Product.hs +++ b/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. -- diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index d2d2f36b7..1f7636fe1 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/Tree.hs b/tools/lsp/squirrel/src/Tree.hs index 6051bac2e..a6ccd6c3e 100644 --- a/tools/lsp/squirrel/src/Tree.hs +++ b/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" - Right (i, ls) -> + Left _ -> "ERR" + 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. --