Silence warnings

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)

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

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

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"

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

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

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

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
 

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:

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

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)

tools/lsp/squirrel/src/TH.hs

@@ -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
-

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
 

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 ()