diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 652947351..973f244fb 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -222,16 +222,16 @@ loadFromVFS funs uri = do (tree, _) <- runParserM . recognise =<< toParseTree (Text fin txt) return $ addLocalScopes tree -loadByURI - :: J.Uri - -> IO (LIGO Info') -loadByURI uri = do - case J.uriToFilePath uri of - Just fin -> do - (tree, _) <- runParserM . recognise =<< toParseTree (Path fin) - return $ addLocalScopes tree - Nothing -> do - error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed." +-- loadByURI +-- :: J.Uri +-- -> IO (LIGO Info') +-- loadByURI uri = do +-- case J.uriToFilePath uri of +-- Just fin -> do +-- (tree, _) <- runParserM . recognise =<< toParseTree (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/src/AST/Completion.hs b/tools/lsp/squirrel/src/AST/Completion.hs index 1e2353a36..a9c140be5 100644 --- a/tools/lsp/squirrel/src/AST/Completion.hs +++ b/tools/lsp/squirrel/src/AST/Completion.hs @@ -12,11 +12,11 @@ import Duplo.Pretty import AST.Types import AST.Scope -import AST.Parser +-- import AST.Parser import Range import Product -import Debug.Trace +-- import Debug.Trace complete @@ -32,13 +32,13 @@ complete complete r tree = do let l = spineTo (leq r . getElem) tree word <- listToMaybe l - let scope = getElem (extract word) - let cat = getElem (extract word) + let scope = getElem (extract word) + let nameCat = getElem (extract word) return $ filter (isSubseqOf (ppToText word)) $ nub $ map (ppToText . _sdName) - $ filter (fits cat . catFromType) + $ filter (fits nameCat . catFromType) $ scope isSubseqOf :: Text -> Text -> Bool diff --git a/tools/lsp/squirrel/src/AST/Find.hs b/tools/lsp/squirrel/src/AST/Find.hs index d94ead728..3967127e9 100644 --- a/tools/lsp/squirrel/src/AST/Find.hs +++ b/tools/lsp/squirrel/src/AST/Find.hs @@ -17,7 +17,7 @@ import AST.Scope import Product import Range -import Debug.Trace +-- import Debug.Trace type CanSearch xs = ( Contains [ScopedDecl] xs diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 6afa47658..a159e3b9b 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -6,12 +6,7 @@ module AST.Parser -- (example, contract, sample) where -import Control.Arrow - import Data.Maybe (isJust) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Sum (Element) import AST.Types @@ -19,13 +14,13 @@ import Duplo.Error import Duplo.Tree import Duplo.Pretty -import Range import Product import Parser import ParseTree -import Debug.Trace +-- import Debug.Trace +example :: FilePath -- example = "../../../src/test/contracts/arithmetic.ligo" -- example = "../../../src/test/contracts/address.ligo" -- example = "../../../src/test/contracts/annotation.ligo" @@ -115,7 +110,6 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope "map_patch" -> MapPatch <$> field "container" <*> fields "binding" "set_patch" -> SetPatch <$> field "container" <*> fields "key" "set_remove" -> SetRemove <$> field "key" <*> field "container" - "map_remove" -> SetRemove <$> field "key" <*> field "container" "update_record" -> RecordUpd <$> field "record" <*> fields "assignment" _ -> fallthrough @@ -272,14 +266,14 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope -- Err , Descent do - \(r :> _, ParseTree _ _ text) -> do + \(r :> _, ParseTree _ _ text') -> do withComments do - return (r :> N :> Nil, Err text) + return (r :> N :> Nil, Err text') , Descent do \case - (r :> _, ParseTree "ERROR" _ text) -> do - return ([] :> r :> Y :> Nil, Err text) + (r :> _, ParseTree "ERROR" _ text') -> do + return ([] :> r :> Y :> Nil, Err text') _ -> fallthrough ] diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 75da0cde9..6e8053c21 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -13,9 +13,8 @@ module AST.Scope -- ) where -import Control.Arrow (first, second) +import Control.Arrow (second) import Control.Monad.State -import Control.Monad.Identity import Control.Monad.Catch import Control.Monad.Catch.Pure @@ -23,23 +22,20 @@ import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (listToMaybe) -import Data.Sum (Element, Apply, Sum) import Data.Text (Text) -import Data.Either (fromRight) 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 Product import Range -import Debug.Trace +-- import Debug.Trace type CollectM = StateT (Product [FullEnv, [Range]]) Catch @@ -141,6 +137,7 @@ unLetRec = descent leaveBe linearize :: Range -> LIGO (Product xs) -> [LIGO (Product xs)] -> LIGO (Product xs) linearize r b [x] = make (modElem @Range (delta r) $ extract x, Let x b) linearize r b (x : xs) = make (modElem @Range (delta r) $ extract x, Let x (linearize r b xs)) + linearize _ _ [] = error "empty Seq" delta (Range _ f _) (Range s _ t) = Range s f t diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 998eed330..8b4fea851 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -4,7 +4,6 @@ module Parser where import Control.Arrow import Control.Monad.Catch import Control.Monad.RWS hiding (Product) -import Control.Monad.Trans.Maybe import Data.String.Interpolate (i) import Data.Text (Text) @@ -18,7 +17,7 @@ import ParseTree import Range import Product -import Debug.Trace +-- import Dsebug.Trace {- Comment grabber has 2 buffers: 1 and 2. @@ -40,7 +39,7 @@ data Failure = Failure String deriving anyclass (Exception) instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where - before (r :> _ :> _) (ParseTree ty cs s) = do + before (r :> _ :> _) (ParseTree _ cs _) = do let (comms, rest) = allComments cs let (comms1, _) = allComments $ reverse rest modify $ first (++ comms) @@ -50,12 +49,12 @@ instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where tell $ fmap (\t -> (r, Err t)) errs after _ _ = do - modify \(x, y) -> (y, []) + modify \(_, y) -> (y, []) grabComments :: ParserM [Text] grabComments = do ls <- gets fst - modify \(x, y) -> ([], y) + modify \(_, y) -> ([], y) return ls allComments :: [RawTree] -> ([Text], [RawTree]) @@ -73,9 +72,10 @@ allErrors = map getBody . filter isUnnamedError where isUnnamedError :: RawTree -> Bool isUnnamedError tree = case only tree of - (r :> "" :> _, ParseTree "ERROR" _ _) -> True + (_ :> "" :> _, ParseTree "ERROR" _ _) -> True _ -> False +getBody :: RawTree -> Text getBody (gist -> f) = ptSource f field :: Text -> ParserM RawTree @@ -90,7 +90,7 @@ fieldOpt name = ask >>= go | n == name = return (Just tree) | otherwise = go rest - go [] = return Nothing + go _ = return Nothing fields :: Text -> ParserM [RawTree] fields name = ask >>= go @@ -98,7 +98,7 @@ fields name = ask >>= go go (tree@(extract -> _ :> n :> _) : rest) = (if n == name then ((tree :) <$>) else id) $ go rest - go [] = return [] + go _ = return [] data ShowRange = Y | N @@ -122,11 +122,13 @@ instance = ascribeRange (getElem @Range xs) (getElem xs) . ascribeComms (getElem xs) +ascribeComms :: [Text] -> Doc -> Doc ascribeComms comms | null comms = id | otherwise = \d -> block $ map (pp . Text.init) comms ++ [d] +ascribeRange :: Pretty p => p -> ShowRange -> Doc -> Doc ascribeRange r Y = (pp r $$) ascribeRange _ _ = id @@ -142,8 +144,8 @@ boilerplate -> ParserM (Info, f RawTree) boilerplate f (r :> _, ParseTree ty cs _) = do withComments do - f <- local (const cs) $ f ty - return $ (r :> N :> Nil, f) + f' <- local (const cs) $ f ty + return $ (r :> N :> Nil, f') boilerplate' :: ((Text, Text) -> ParserM (f RawTree)) @@ -151,8 +153,8 @@ boilerplate' -> ParserM (Info, f RawTree) boilerplate' f (r :> _, ParseTree ty cs src) = do withComments do - f <- local (const cs) $ f (ty, src) - return $ (r :> N :> Nil, f) + f' <- local (const cs) $ f (ty, src) + return $ (r :> N :> Nil, f') fallthrough :: MonadThrow m => m a fallthrough = throwM HandlerFailed