From 9d81ecf3539aa7f0ae4f6304f7ed6aaac2196e4b Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Thu, 4 Jun 2020 17:16:04 +0400 Subject: [PATCH] Silence warnings --- tools/lsp/squirrel/app/Main.hs | 14 +++----- tools/lsp/squirrel/package.yaml | 3 +- tools/lsp/squirrel/squirrel.cabal | 4 +-- tools/lsp/squirrel/src/AST/Parser.hs | 37 ++++++++++++++----- tools/lsp/squirrel/src/AST/Scope.hs | 35 ++++++------------ tools/lsp/squirrel/src/AST/Types.hs | 15 ++------ tools/lsp/squirrel/src/Error.hs | 1 - tools/lsp/squirrel/src/ParseTree.hs | 4 --- tools/lsp/squirrel/src/Parser.hs | 53 ++++++++++------------------ tools/lsp/squirrel/src/Pretty.hs | 2 +- tools/lsp/squirrel/src/Range.hs | 2 -- tools/lsp/squirrel/src/TH.hs | 10 ------ tools/lsp/squirrel/src/Union.hs | 4 +-- tools/lsp/squirrel/src/Update.hs | 10 ++---- 14 files changed, 72 insertions(+), 122 deletions(-) delete mode 100644 tools/lsp/squirrel/src/TH.hs diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 4dc2b40ee..03d971244 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -1,6 +1,4 @@ -import Data.Foldable (for_) - import Control.Concurrent import Control.Concurrent.STM import Control.Exception as E @@ -18,17 +16,14 @@ import Language.Haskell.LSP.Messages as Msg import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J import qualified Language.Haskell.LSP.Utility as U -import Language.Haskell.LSP.VFS +-- import Language.Haskell.LSP.VFS -import System.Environment import System.Exit import qualified System.Log as L -import ParseTree import Parser import Range import AST hiding (def) -import Pretty import Error main :: IO () @@ -51,7 +46,6 @@ mainLoop = do Core.setupLogger (Just "log.txt") [] L.INFO CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt") - return 0 `catches` [ Handler \(e :: SomeException) -> do print e @@ -155,7 +149,7 @@ eventLoop funs chan = do (J.uriToFilePath doc) (Just 0) - _ -> putStrLn "unknown msg" + _ -> U.logs "unknown msg" collectErrors @@ -172,8 +166,10 @@ collectErrors funs uri path version = do $ partitionBySource $ map errorToDiag (errs <> errors tree) + Nothing -> error "TODO: implement URI file loading" + errorToDiag :: Error ASTInfo -> J.Diagnostic -errorToDiag (Expected what instead (getRange -> (Range (sl, sc, _) (el, ec, _)))) = +errorToDiag (Expected what _ (getRange -> (Range (sl, sc, _) (el, ec, _)))) = J.Diagnostic (J.Range begin end) (Just J.DsError) diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index ea5510d0a..9dd208ca3 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -5,7 +5,6 @@ dependencies: - bytestring - data-default - data-fix - - lens - mtl - pretty - template-haskell @@ -54,7 +53,7 @@ library: executables: squirrel: dependencies: - - base + - lens - stm - haskell-lsp - squirrel diff --git a/tools/lsp/squirrel/squirrel.cabal b/tools/lsp/squirrel/squirrel.cabal index 6463c1fd9..abf9bc6f7 100644 --- a/tools/lsp/squirrel/squirrel.cabal +++ b/tools/lsp/squirrel/squirrel.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a49f1d3cbdae65e52d4685178a1d0fc9b72502cc4b3c8cfa45f245ffdf32922d +-- hash: b811c8b08ccf5e457be7e405973ea06f046839b90e70ebd729a1df9bb668dc69 name: squirrel version: 0.0.0 @@ -23,7 +23,6 @@ library ParseTree Pretty Range - TH Tree Union Update @@ -42,7 +41,6 @@ library , bytestring , data-default , data-fix - , lens , mtl , pretty , template-haskell diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index cca01d390..cd8e78a45 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -11,14 +11,13 @@ module AST.Parser (example, contract) where import Data.Text (Text) -import AST.Types hiding (tuple) +import AST.Types import Parser -import Range import Tree import Union -import Debug.Trace +-- import Debug.Trace ranged :: ( Functor f @@ -55,6 +54,7 @@ declaration <|> do ranged do pure Action <*> attributes <|> do include +include :: Parser (Pascal ASTInfo) include = do subtree "include" do ranged do @@ -101,6 +101,7 @@ binding = do <*> inside "type:" type_ <*> inside "body:" letExpr +recursive :: Parser Bool recursive = do mr <- optional do inside "recursive" do @@ -173,6 +174,7 @@ set_patch = do <*> inside "container:path" (qname <|> projection) <*> many do inside "key" expr +record_update :: Parser (Pascal ASTInfo) record_update = do subtree "update_record" do ranged do @@ -180,6 +182,7 @@ record_update = do <*> inside "record:path" do qname <|> projection <*> many do inside "assignment" field_path_assignment +field_path_assignment :: Parser (Pascal ASTInfo) field_path_assignment = do subtree "field_path_assignment" do ranged do @@ -187,6 +190,7 @@ field_path_assignment = do <*> inside "lhs:path" do qname <|> projection <*> inside "_rhs" expr +map_patch :: Parser (Pascal ASTInfo) map_patch = do subtree "map_patch" do ranged do @@ -201,6 +205,7 @@ set_expr = do pure List <*> many do inside "element" expr +lambda_expr :: Parser (Pascal ASTInfo) lambda_expr = do subtree "fun_expr" do ranged do @@ -210,6 +215,7 @@ lambda_expr = do <*> inside "type" newtype_ <*> inside "body" expr +seq_expr :: Parser (Pascal ASTInfo) seq_expr = do subtree "block" do ranged do @@ -217,10 +223,12 @@ seq_expr = do inside "statement" do declaration <|> statement +loop :: Parser (Pascal ASTInfo) loop = do subtree "loop" do for_loop <|> while_loop <|> for_container +for_container :: Parser (Pascal ASTInfo) for_container = do subtree "for_loop" do ranged do @@ -231,6 +239,7 @@ for_container = do <*> inside "collection" expr <*> inside "body" (expr <|> seq_expr) +while_loop :: Parser (Pascal ASTInfo) while_loop = do subtree "while_loop" do ranged do @@ -238,6 +247,7 @@ while_loop = do <*> inside "breaker" expr <*> inside "body" expr +for_loop :: Parser (Pascal ASTInfo) for_loop = do subtree "for_loop" do ranged do @@ -247,6 +257,7 @@ for_loop = do <*> inside "end" expr <*> inside "body" expr +clause_block :: Parser (Pascal ASTInfo) clause_block = do subtree "clause_block" do inside "block:block" do @@ -400,6 +411,7 @@ nullary_ctor = do true <|> false <|> none <|> unit <*> pure [] +true, false, none, unit :: Parser Text true = token "True" false = token "False" none = token "None" @@ -617,7 +629,7 @@ method_call = do <*> optional do inside "arguments" arguments where apply' i f (Just xs) = Apply (mk i $ Ident f) xs - apply' i f _ = Ident f + apply' _ f _ = Ident f projection :: Parser (Pascal ASTInfo) projection = do @@ -650,7 +662,7 @@ par_call = do -> Maybe [Pascal ASTInfo] -> Pascal ASTInfo apply' i f (Just xs) = mk i $ Apply f xs - apply' i f _ = f + apply' _ f _ = f int_literal :: Parser (Pascal ASTInfo) int_literal = do @@ -678,6 +690,7 @@ fun_call = do <*> ranged do pure Ident <*> inside "f" function_id <*> inside "arguments" arguments +arguments :: Parser [Pascal ASTInfo] arguments = subtree "arguments" do many do inside "argument" expr @@ -708,6 +721,7 @@ opCall = do <*> inside "negate" anything <*> inside "arg" expr +letExpr :: Parser (Pascal ASTInfo) letExpr = do subtree "let_expr" do pure let' @@ -733,25 +747,29 @@ paramDecl = do pure Decl <*> inside "access" do ranged do - pure access' <*> anything + access' =<< anything <*> inside "name" name <*> inside "type" type_ where - access' "var" = Mutable - access' "const" = Immutable + access' "var" = pure Mutable + access' "const" = pure Immutable + access' _ = die "`var` or `const`" +newtype_ :: Parser (Pascal ASTInfo) newtype_ = select [ record_type , type_ , sum_type ] +sum_type :: Parser (Pascal ASTInfo) sum_type = do subtree "sum_type" do ranged do pure TSum <*> many do inside "variant" variant +variant :: Parser (Pascal ASTInfo) variant = do subtree "variant" do ranged do @@ -759,6 +777,7 @@ variant = do <*> inside "constructor:constr" capitalName <*> optional do inside "arguments" type_ +record_type :: Parser (Pascal ASTInfo) record_type = do subtree "record_type" do ranged do @@ -766,6 +785,7 @@ record_type = do inside "field" do field_decl +field_decl :: Parser (Pascal ASTInfo) field_decl = do subtree "field_decl" do ranged do @@ -841,6 +861,7 @@ typeTuple = do -- example = "../../../src/test/contracts/bytes_arithmetic.ligo" -- example = "../../../src/test/contracts/bytes_unpack.ligo" -- example = "../../../src/test/contracts/chain_id.ligo" +example :: Text example = "../../../src/test/contracts/coase.ligo" -- example = "../../../src/test/contracts/failwith.ligo" -- example = "../../../src/test/contracts/loop.ligo" diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 98c0c26b5..2895f13c8 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -21,13 +21,9 @@ module AST.Scope ) where -import Control.Lens hiding (Const, List) import Control.Monad.State -import Data.Maybe import Data.Text (Text) -import Data.Traversable -import Data.Foldable import Parser import Range @@ -53,22 +49,11 @@ data ScopedDecl = ScopedDecl data Kind = Star -instance HasMethods ScopeM where - data Methods ScopeM = MethodsScopeM - { enter_ :: ScopeM () - , leave_ :: ScopeM () - , define_ :: ScopedDecl -> ScopeM () - } - - method = MethodsScopeM - { enter_ = modify \(a : b) -> a : a : b - , leave_ = modify tail - , define_ = \d -> modify \(Env a : b) -> Env (d : a) : b - } - -enter = enter_ method -leave = leave_ method -define = define_ method +enter, leave :: ScopeM () +define :: ScopedDecl -> ScopeM () +enter = modify \(a : b) -> a : a : b +leave = modify tail +define d = modify \(Env a : b) -> Env (d : a) : b defType :: HasRange a => Pascal a -> Kind -> Pascal a -> ScopeM () defType name kind body = do @@ -113,7 +98,7 @@ instance HasRange a => UpdateOver ScopeM Declaration (Pascal a) where instance HasRange a => UpdateOver ScopeM Binding (Pascal a) where before = \case - Function recur name args ty body -> do + Function recur name _args ty body -> do when recur do def name (Just ty) (Just body) enter @@ -124,7 +109,7 @@ instance HasRange a => UpdateOver ScopeM Binding (Pascal a) where Irrefutable name body -> do leave; def name Nothing (Just body) Var name ty body -> do leave; def name (Just ty) (Just body) Const name ty body -> do leave; def name (Just ty) (Just body) - Function recur name args ty body -> do + Function recur name _args ty body -> do leave unless recur do def name (Just ty) (Just body) @@ -334,9 +319,9 @@ instance HasComments Scope where evalScopeM :: ScopeM a -> a evalScopeM action = evalState action [Env []] -testUpdate :: Pascal ASTInfo -> ScopeM (Pascal Scope) -testUpdate = updateTree \_ -> do +_testUpdate :: Pascal ASTInfo -> ScopeM (Pascal Scope) +_testUpdate = updateTree \_ -> do Env topmost <- gets head let names = _sdName <$> topmost - let res = ppToText $ fsep $ map pp names + let res = ppToText $ fsep $ map pp names return $ Scope res \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index 3f4b4437e..0a251cceb 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/tools/lsp/squirrel/src/AST/Types.hs @@ -6,21 +6,12 @@ module AST.Types where -import Control.Monad.State -import Control.Lens hiding (Const, List) - -import qualified Data.Text as Text import Data.Text (Text) -import Data.Void -import Parser -import ParseTree import Pretty import Tree -import TH - -import Debug.Trace +-- import Debug.Trace -- | The AST for Pascali... wait. It is, em, universal one. -- @@ -199,7 +190,7 @@ instance Pretty1 Declaration where instance Pretty1 Binding where pp1 = \case - Irrefutable pat expr -> error "irrefs in pascaligo?" + Irrefutable pat expr -> "irref" <+> pat <+> "=" `indent` expr Function isRec name params ty body -> ( ( @@ -232,8 +223,6 @@ instance Pretty1 Type where TSum variants -> block variants TProduct elements -> train " *" elements TApply f xs -> f <> tuple xs - where - ppField (name, ty) = name <> ": " <> ty <> ";" instance Pretty1 Variant where pp1 = \case diff --git a/tools/lsp/squirrel/src/Error.hs b/tools/lsp/squirrel/src/Error.hs index ac04cc125..a62c90ac9 100644 --- a/tools/lsp/squirrel/src/Error.hs +++ b/tools/lsp/squirrel/src/Error.hs @@ -9,7 +9,6 @@ module Error import Data.Text (Text, pack) import Pretty -import Range -- | Parse error. data Error info diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index ff31bbd11..38917d098 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -23,8 +23,6 @@ import qualified Data.ByteString as BS import qualified Data.Text as Text import Data.Text (Text) import Data.Traversable (for) -import Data.Text.Encoding -import Data.Text.Foreign (withCStringLen) import TreeSitter.Parser import TreeSitter.Tree @@ -44,8 +42,6 @@ import Control.Monad ((>=>)) import Text.PrettyPrint hiding ((<>)) -import Paths_squirrel - import Range import Pretty diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index f8f5667bb..b40200b33 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -46,6 +46,9 @@ module Parser , getInfo , inside + -- * Error + , die + -- * Replacement for `Alternative`, because reasons , many , some @@ -63,19 +66,12 @@ module Parser import Control.Lens hiding (inside) import Control.Monad.State import Control.Monad.Writer -import Control.Monad.Reader import Control.Monad.Except -import Control.Monad.Identity import Data.Foldable -import Data.Traversable -import Data.Functor -import Data.Text (Text, pack, unpack) +import Data.Text (Text, unpack) import qualified Data.Text as Text -import qualified Data.ByteString as ByteString -import Data.ByteString (ByteString) - import ParseTree import Range import Pretty @@ -132,8 +128,8 @@ takeNext msg = do (_, t) : f -> do if "comment" `Text.isSuffixOf` ptName t then do - (st, comms) <- get - put (st, ptSource t : comms) + (st', comms') <- get + put (st', ptSource t : comms') takeNext msg else do put @@ -210,15 +206,15 @@ field name parser = do -- | Variuos error reports. fallback :: Stubbed a ASTInfo => Text -> Parser a -fallback' :: Stubbed a ASTInfo => Text -> ASTInfo -> Parser a +-- fallback' :: Stubbed a ASTInfo => Text -> ASTInfo -> Parser a die :: Text -> Parser a die' :: Text -> ASTInfo -> Parser a -complain :: Text -> ASTInfo -> Parser () +-- complain :: Text -> ASTInfo -> Parser () fallback msg = pure . stub =<< makeError msg -fallback' msg rng = pure . stub =<< makeError' msg rng +-- fallback' msg rng = pure . stub =<< makeError' msg rng die msg = throwError =<< makeError msg die' msg rng = throwError =<< makeError' msg rng -complain msg rng = tell . pure =<< makeError' msg rng +-- complain msg rng = tell . pure =<< makeError' msg rng -- | When tree-sitter found something it was unable to process. unexpected :: ParseTree -> Error ASTInfo @@ -285,7 +281,7 @@ some p = some' -- | Run parser on given file. -- runParser :: Parser a -> FilePath -> IO (a, [Error ASTInfo]) -runParser (Parser parser) fin = do +runParser parser fin = do pforest <- toParseTree fin let res = @@ -293,6 +289,7 @@ runParser (Parser parser) fin = do $ runExceptT $ flip runStateT (pforest, []) $ runWriterT + $ unParser $ parser either (error . show) (return . fst) res @@ -313,7 +310,7 @@ debugParser parser fin = do token :: Text -> Parser Text token node = do i <- getInfo - tree@ParseTree {ptName, ptSource} <- takeNext node + ParseTree {ptName, ptSource} <- takeNext node if ptName == node then return ptSource else die' node i @@ -356,14 +353,14 @@ delete k ((k', v) : rest) = else (addIfError v vs, addIfComment v cs, remains) where (vs, cs, remains) = delete k rest - addIfError v = - if ptName v == "ERROR" - then (:) v + addIfError v' = + if ptName v' == "ERROR" + then (:) v' else id - addIfComment v = - if "comment" `Text.isSuffixOf` ptName v - then (ptSource v :) + addIfComment v' = + if "comment" `Text.isSuffixOf` ptName v' + then (ptSource v' :) else id -- | Report all ERRORs from the list. @@ -373,18 +370,6 @@ collectErrors vs = when (ptName v == "ERROR") do tell [unexpected v] --- | Parser negation. -notFollowedBy :: Parser a -> Parser () -notFollowedBy parser = do - good <- do - parser - return False - <|> do - return True - - unless good do - die "notFollowedBy" - -- | Universal accessor. -- -- Usage: diff --git a/tools/lsp/squirrel/src/Pretty.hs b/tools/lsp/squirrel/src/Pretty.hs index 75b017cec..86e80954c 100644 --- a/tools/lsp/squirrel/src/Pretty.hs +++ b/tools/lsp/squirrel/src/Pretty.hs @@ -86,7 +86,7 @@ above a b = hang a 0 b -- | Pretty print as a sequence with given separator. train :: Pretty p => Doc -> [p] -> Doc -train sep = fsep . punctuate sep . map pp +train sep' = fsep . punctuate sep' . map pp -- | Pretty print as a vertical block. block :: Pretty p => [p] -> Doc diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index eed96db17..ed5f074f0 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/tools/lsp/squirrel/src/Range.hs @@ -7,8 +7,6 @@ module Range ) where -import Control.Lens - import qualified Data.ByteString as BS import Data.ByteString (ByteString) import Data.Text (Text) diff --git a/tools/lsp/squirrel/src/TH.hs b/tools/lsp/squirrel/src/TH.hs deleted file mode 100644 index 6707e17ad..000000000 --- a/tools/lsp/squirrel/src/TH.hs +++ /dev/null @@ -1,10 +0,0 @@ - -module TH () where - -import Control.Applicative - -import Language.Haskell.TH.Syntax (Q) - -instance Semigroup a => Semigroup (Q a) where (<>) = liftA2 (<>) -instance Monoid a => Monoid (Q a) where mempty = pure mempty - diff --git a/tools/lsp/squirrel/src/Union.hs b/tools/lsp/squirrel/src/Union.hs index b89d8722e..04aa35d10 100644 --- a/tools/lsp/squirrel/src/Union.hs +++ b/tools/lsp/squirrel/src/Union.hs @@ -66,11 +66,11 @@ instance Member f fs => Member f (g : fs) where inj = There . inj proj = eliminate (const Nothing) proj -instance HasMethods m => UpdateOver m (Union '[]) a where +instance Monad m => UpdateOver m (Union '[]) a where before = error "Union.empty" after = error "Union.empty" -instance (HasMethods m, UpdateOver m f a, UpdateOver m (Union fs) a) => UpdateOver m (Union (f : fs)) a where +instance (UpdateOver m f a, UpdateOver m (Union fs) a) => UpdateOver m (Union (f : fs)) a where before = eliminate before before after = eliminate after after diff --git a/tools/lsp/squirrel/src/Update.hs b/tools/lsp/squirrel/src/Update.hs index b56145aaf..f133e5716 100644 --- a/tools/lsp/squirrel/src/Update.hs +++ b/tools/lsp/squirrel/src/Update.hs @@ -4,21 +4,15 @@ module Update ( -- * Interfaces - HasMethods(..) - , UpdateOver(..) + UpdateOver(..) -- * Default implementation , skip ) where --- | Abstraction over monad capabilities. -class Monad m => HasMethods m where - data Methods m :: * - method :: Methods m - -- | Update callbacks for a @f a@ while working inside monad @m@. -class HasMethods m => UpdateOver m f a where +class Monad m => UpdateOver m f a where before :: f a -> m () after :: f a -> m ()