balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Silence warnings

Browse Source
This commit is contained in:
Kirill Andreev 2020-06-04 17:16:04 +04:00
parent 1f7af3c8cb
commit 9d81ecf353
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
14 changed files with 72 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
tools/lsp/squirrel/app/Main.hs
View File

@ -1,6 +1,4 @@
import Data.Foldable (for_)
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception as E 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 as J
import qualified Language.Haskell.LSP.Types.Lens as J import qualified Language.Haskell.LSP.Types.Lens as J
import qualified Language.Haskell.LSP.Utility as U 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 System.Exit
import qualified System.Log as L import qualified System.Log as L
import ParseTree
import Parser import Parser
import Range import Range
import AST hiding (def) import AST hiding (def)
import Pretty
import Error import Error
main :: IO () main :: IO ()
@ -51,7 +46,6 @@ mainLoop = do
Core.setupLogger (Just "log.txt") [] L.INFO Core.setupLogger (Just "log.txt") [] L.INFO
CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt") CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt")
return 0
`catches` `catches`
[ Handler \(e :: SomeException) -> do [ Handler \(e :: SomeException) -> do
print e print e
@ -155,7 +149,7 @@ eventLoop funs chan = do
(J.uriToFilePath doc) (J.uriToFilePath doc)
(Just 0) (Just 0)
_ -> putStrLn "unknown msg" _ -> U.logs "unknown msg"
collectErrors collectErrors
@ -172,8 +166,10 @@ collectErrors funs uri path version = do
$ partitionBySource $ partitionBySource
$ map errorToDiag (errs <> errors tree) $ map errorToDiag (errs <> errors tree)
Nothing -> error "TODO: implement URI file loading"
errorToDiag :: Error ASTInfo -> J.Diagnostic 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.Diagnostic
(J.Range begin end) (J.Range begin end)
(Just J.DsError) (Just J.DsError)

3
tools/lsp/squirrel/package.yaml
View File

@ -5,7 +5,6 @@ dependencies:
- bytestring - bytestring
- data-default - data-default
- data-fix - data-fix
- lens
- mtl - mtl
- pretty - pretty
- template-haskell - template-haskell
@ -54,7 +53,7 @@ library:
executables: executables:
squirrel: squirrel:
dependencies: dependencies:
- base - lens
- stm - stm
- haskell-lsp - haskell-lsp
- squirrel - squirrel

4
tools/lsp/squirrel/squirrel.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: a49f1d3cbdae65e52d4685178a1d0fc9b72502cc4b3c8cfa45f245ffdf32922d -- hash: b811c8b08ccf5e457be7e405973ea06f046839b90e70ebd729a1df9bb668dc69
name: squirrel name: squirrel
version: 0.0.0 version: 0.0.0
@ -23,7 +23,6 @@ library
ParseTree ParseTree
Pretty Pretty
Range Range
TH
Tree Tree
Union Union
Update Update
@ -42,7 +41,6 @@ library
, bytestring , bytestring
, data-default , data-default
, data-fix , data-fix
, lens
, mtl , mtl
, pretty , pretty
, template-haskell , template-haskell

37
tools/lsp/squirrel/src/AST/Parser.hs
View File

@ -11,14 +11,13 @@ module AST.Parser (example, contract) where
import Data.Text (Text) import Data.Text (Text)
import AST.Types hiding (tuple) import AST.Types
import Parser import Parser
import Range
import Tree import Tree
import Union import Union
import Debug.Trace -- import Debug.Trace
ranged ranged
:: ( Functor f :: ( Functor f
@ -55,6 +54,7 @@ declaration
<|> do ranged do pure Action <*> attributes <|> do ranged do pure Action <*> attributes
<|> do include <|> do include
include :: Parser (Pascal ASTInfo)
include = do include = do
subtree "include" do subtree "include" do
ranged do ranged do
@ -101,6 +101,7 @@ binding = do
<*> inside "type:" type_ <*> inside "type:" type_
<*> inside "body:" letExpr <*> inside "body:" letExpr
recursive :: Parser Bool
recursive = do recursive = do
mr <- optional do mr <- optional do
inside "recursive" do inside "recursive" do
@ -173,6 +174,7 @@ set_patch = do
<*> inside "container:path" (qname <|> projection) <*> inside "container:path" (qname <|> projection)
<*> many do inside "key" expr <*> many do inside "key" expr
record_update :: Parser (Pascal ASTInfo)
record_update = do record_update = do
subtree "update_record" do subtree "update_record" do
ranged do ranged do
@ -180,6 +182,7 @@ record_update = do
<*> inside "record:path" do qname <|> projection <*> inside "record:path" do qname <|> projection
<*> many do inside "assignment" field_path_assignment <*> many do inside "assignment" field_path_assignment
field_path_assignment :: Parser (Pascal ASTInfo)
field_path_assignment = do field_path_assignment = do
subtree "field_path_assignment" do subtree "field_path_assignment" do
ranged do ranged do
@ -187,6 +190,7 @@ field_path_assignment = do
<*> inside "lhs:path" do qname <|> projection <*> inside "lhs:path" do qname <|> projection
<*> inside "_rhs" expr <*> inside "_rhs" expr
map_patch :: Parser (Pascal ASTInfo)
map_patch = do map_patch = do
subtree "map_patch" do subtree "map_patch" do
ranged do ranged do
@ -201,6 +205,7 @@ set_expr = do
pure List <*> many do pure List <*> many do
inside "element" expr inside "element" expr
lambda_expr :: Parser (Pascal ASTInfo)
lambda_expr = do lambda_expr = do
subtree "fun_expr" do subtree "fun_expr" do
ranged do ranged do
@ -210,6 +215,7 @@ lambda_expr = do
<*> inside "type" newtype_ <*> inside "type" newtype_
<*> inside "body" expr <*> inside "body" expr
seq_expr :: Parser (Pascal ASTInfo)
seq_expr = do seq_expr = do
subtree "block" do subtree "block" do
ranged do ranged do
@ -217,10 +223,12 @@ seq_expr = do
inside "statement" do inside "statement" do
declaration <|> statement declaration <|> statement
loop :: Parser (Pascal ASTInfo)
loop = do loop = do
subtree "loop" do subtree "loop" do
for_loop <|> while_loop <|> for_container for_loop <|> while_loop <|> for_container
for_container :: Parser (Pascal ASTInfo)
for_container = do for_container = do
subtree "for_loop" do subtree "for_loop" do
ranged do ranged do
@ -231,6 +239,7 @@ for_container = do
<*> inside "collection" expr <*> inside "collection" expr
<*> inside "body" (expr <|> seq_expr) <*> inside "body" (expr <|> seq_expr)
while_loop :: Parser (Pascal ASTInfo)
while_loop = do while_loop = do
subtree "while_loop" do subtree "while_loop" do
ranged do ranged do
@ -238,6 +247,7 @@ while_loop = do
<*> inside "breaker" expr <*> inside "breaker" expr
<*> inside "body" expr <*> inside "body" expr
for_loop :: Parser (Pascal ASTInfo)
for_loop = do for_loop = do
subtree "for_loop" do subtree "for_loop" do
ranged do ranged do
@ -247,6 +257,7 @@ for_loop = do
<*> inside "end" expr <*> inside "end" expr
<*> inside "body" expr <*> inside "body" expr
clause_block :: Parser (Pascal ASTInfo)
clause_block = do clause_block = do
subtree "clause_block" do subtree "clause_block" do
inside "block:block" do inside "block:block" do
@ -400,6 +411,7 @@ nullary_ctor = do
true <|> false <|> none <|> unit true <|> false <|> none <|> unit
<*> pure [] <*> pure []
true, false, none, unit :: Parser Text
true = token "True" true = token "True"
false = token "False" false = token "False"
none = token "None" none = token "None"
@ -617,7 +629,7 @@ method_call = do
<*> optional do inside "arguments" arguments <*> optional do inside "arguments" arguments
where where
apply' i f (Just xs) = Apply (mk i $ Ident f) xs 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 :: Parser (Pascal ASTInfo)
projection = do projection = do
@ -650,7 +662,7 @@ par_call = do
-> Maybe [Pascal ASTInfo] -> Maybe [Pascal ASTInfo]
-> Pascal ASTInfo -> Pascal ASTInfo
apply' i f (Just xs) = mk i $ Apply f xs apply' i f (Just xs) = mk i $ Apply f xs
apply' i f _ = f apply' _ f _ = f
int_literal :: Parser (Pascal ASTInfo) int_literal :: Parser (Pascal ASTInfo)
int_literal = do int_literal = do
@ -678,6 +690,7 @@ fun_call = do
<*> ranged do pure Ident <*> inside "f" function_id <*> ranged do pure Ident <*> inside "f" function_id
<*> inside "arguments" arguments <*> inside "arguments" arguments
arguments :: Parser [Pascal ASTInfo]
arguments = arguments =
subtree "arguments" do subtree "arguments" do
many do inside "argument" expr many do inside "argument" expr
@ -708,6 +721,7 @@ opCall = do
<*> inside "negate" anything <*> inside "negate" anything
<*> inside "arg" expr <*> inside "arg" expr
letExpr :: Parser (Pascal ASTInfo)
letExpr = do letExpr = do
subtree "let_expr" do subtree "let_expr" do
pure let' pure let'
@ -733,25 +747,29 @@ paramDecl = do
pure Decl pure Decl
<*> inside "access" do <*> inside "access" do
ranged do ranged do
pure access' <*> anything access' =<< anything
<*> inside "name" name <*> inside "name" name
<*> inside "type" type_ <*> inside "type" type_
where where
access' "var" = Mutable access' "var" = pure Mutable
access' "const" = Immutable access' "const" = pure Immutable
access' _ = die "`var` or `const`"
newtype_ :: Parser (Pascal ASTInfo)
newtype_ = select newtype_ = select
[ record_type [ record_type
, type_ , type_
, sum_type , sum_type
] ]
sum_type :: Parser (Pascal ASTInfo)
sum_type = do sum_type = do
subtree "sum_type" do subtree "sum_type" do
ranged do ranged do
pure TSum <*> many do pure TSum <*> many do
inside "variant" variant inside "variant" variant
variant :: Parser (Pascal ASTInfo)
variant = do variant = do
subtree "variant" do subtree "variant" do
ranged do ranged do
@ -759,6 +777,7 @@ variant = do
<*> inside "constructor:constr" capitalName <*> inside "constructor:constr" capitalName
<*> optional do inside "arguments" type_ <*> optional do inside "arguments" type_
record_type :: Parser (Pascal ASTInfo)
record_type = do record_type = do
subtree "record_type" do subtree "record_type" do
ranged do ranged do
@ -766,6 +785,7 @@ record_type = do
inside "field" do inside "field" do
field_decl field_decl
field_decl :: Parser (Pascal ASTInfo)
field_decl = do field_decl = do
subtree "field_decl" do subtree "field_decl" do
ranged do ranged do
@ -841,6 +861,7 @@ typeTuple = do
-- example = "../../../src/test/contracts/bytes_arithmetic.ligo" -- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
-- example = "../../../src/test/contracts/bytes_unpack.ligo" -- example = "../../../src/test/contracts/bytes_unpack.ligo"
-- example = "../../../src/test/contracts/chain_id.ligo" -- example = "../../../src/test/contracts/chain_id.ligo"
example :: Text
example = "../../../src/test/contracts/coase.ligo" example = "../../../src/test/contracts/coase.ligo"
-- example = "../../../src/test/contracts/failwith.ligo" -- example = "../../../src/test/contracts/failwith.ligo"
-- example = "../../../src/test/contracts/loop.ligo" -- example = "../../../src/test/contracts/loop.ligo"

35
tools/lsp/squirrel/src/AST/Scope.hs
View File

@ -21,13 +21,9 @@ module AST.Scope
) )
where where
import Control.Lens hiding (Const, List)
import Control.Monad.State import Control.Monad.State
import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable
import Data.Foldable
import Parser import Parser
import Range import Range
@ -53,22 +49,11 @@ data ScopedDecl = ScopedDecl
data Kind = Star data Kind = Star
instance HasMethods ScopeM where enter, leave :: ScopeM ()
data Methods ScopeM = MethodsScopeM define :: ScopedDecl -> ScopeM ()
{ enter_ :: ScopeM () enter = modify \(a : b) -> a : a : b
, leave_ :: ScopeM () leave = modify tail
, define_ :: ScopedDecl -> ScopeM () define d = modify \(Env a : b) -> Env (d : a) : b
}
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
defType :: HasRange a => Pascal a -> Kind -> Pascal a -> ScopeM () defType :: HasRange a => Pascal a -> Kind -> Pascal a -> ScopeM ()
defType name kind body = do 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 instance HasRange a => UpdateOver ScopeM Binding (Pascal a) where
before = \case before = \case
Function recur name args ty body -> do Function recur name _args ty body -> do
when recur do when recur do
def name (Just ty) (Just body) def name (Just ty) (Just body)
enter enter
@ -124,7 +109,7 @@ instance HasRange a => UpdateOver ScopeM Binding (Pascal a) where
Irrefutable name body -> do leave; def name Nothing (Just body) Irrefutable name body -> do leave; def name Nothing (Just body)
Var name ty body -> do leave; def name (Just ty) (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) 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 leave
unless recur do unless recur do
def name (Just ty) (Just body) def name (Just ty) (Just body)
@ -334,9 +319,9 @@ instance HasComments Scope where
evalScopeM :: ScopeM a -> a evalScopeM :: ScopeM a -> a
evalScopeM action = evalState action [Env []] evalScopeM action = evalState action [Env []]
testUpdate :: Pascal ASTInfo -> ScopeM (Pascal Scope) _testUpdate :: Pascal ASTInfo -> ScopeM (Pascal Scope)
testUpdate = updateTree \_ -> do _testUpdate = updateTree \_ -> do
Env topmost <- gets head Env topmost <- gets head
let names = _sdName <$> topmost let names = _sdName <$> topmost
let res = ppToText $ fsep $ map pp names let res = ppToText $ fsep $ map pp names
return $ Scope res return $ Scope res

15
tools/lsp/squirrel/src/AST/Types.hs
View File

@ -6,21 +6,12 @@
module AST.Types where 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.Text (Text)
import Data.Void
import Parser
import ParseTree
import Pretty import Pretty
import Tree import Tree
import TH -- import Debug.Trace
import Debug.Trace
-- | The AST for Pascali... wait. It is, em, universal one. -- | The AST for Pascali... wait. It is, em, universal one.
-- --
@ -199,7 +190,7 @@ instance Pretty1 Declaration where
instance Pretty1 Binding where instance Pretty1 Binding where
pp1 = \case pp1 = \case
Irrefutable pat expr -> error "irrefs in pascaligo?" Irrefutable pat expr -> "irref" <+> pat <+> "=" `indent` expr
Function isRec name params ty body -> Function isRec name params ty body ->
( (
( (
@ -232,8 +223,6 @@ instance Pretty1 Type where
TSum variants -> block variants TSum variants -> block variants
TProduct elements -> train " *" elements TProduct elements -> train " *" elements
TApply f xs -> f <> tuple xs TApply f xs -> f <> tuple xs
where
ppField (name, ty) = name <> ": " <> ty <> ";"
instance Pretty1 Variant where instance Pretty1 Variant where
pp1 = \case pp1 = \case

1
tools/lsp/squirrel/src/Error.hs
View File

@ -9,7 +9,6 @@ module Error
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Pretty import Pretty
import Range
-- | Parse error. -- | Parse error.
data Error info data Error info

4
tools/lsp/squirrel/src/ParseTree.hs
View File

@ -23,8 +23,6 @@ import qualified Data.ByteString as BS
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable (for) import Data.Traversable (for)
import Data.Text.Encoding
import Data.Text.Foreign (withCStringLen)
import TreeSitter.Parser import TreeSitter.Parser
import TreeSitter.Tree import TreeSitter.Tree
@ -44,8 +42,6 @@ import Control.Monad ((>=>))
import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint hiding ((<>))
import Paths_squirrel
import Range import Range
import Pretty import Pretty

53
tools/lsp/squirrel/src/Parser.hs
View File

@ -46,6 +46,9 @@ module Parser
, getInfo , getInfo
, inside , inside
-- * Error
, die
-- * Replacement for `Alternative`, because reasons -- * Replacement for `Alternative`, because reasons
, many , many
, some , some
@ -63,19 +66,12 @@ module Parser
import Control.Lens hiding (inside) import Control.Lens hiding (inside)
import Control.Monad.State import Control.Monad.State
import Control.Monad.Writer import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Identity
import Data.Foldable import Data.Foldable
import Data.Traversable import Data.Text (Text, unpack)
import Data.Functor
import Data.Text (Text, pack, unpack)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
import ParseTree import ParseTree
import Range import Range
import Pretty import Pretty
@ -132,8 +128,8 @@ takeNext msg = do
(_, t) : f -> do (_, t) : f -> do
if "comment" `Text.isSuffixOf` ptName t if "comment" `Text.isSuffixOf` ptName t
then do then do
(st, comms) <- get (st', comms') <- get
put (st, ptSource t : comms) put (st', ptSource t : comms')
takeNext msg takeNext msg
else do else do
put put
@ -210,15 +206,15 @@ field name parser = do
-- | Variuos error reports. -- | Variuos error reports.
fallback :: Stubbed a ASTInfo => Text -> Parser a 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 -> Parser a
die' :: Text -> ASTInfo -> Parser a die' :: Text -> ASTInfo -> Parser a
complain :: Text -> ASTInfo -> Parser () -- complain :: Text -> ASTInfo -> Parser ()
fallback msg = pure . stub =<< makeError msg 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 = throwError =<< makeError msg
die' msg rng = throwError =<< makeError' msg rng 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. -- | When tree-sitter found something it was unable to process.
unexpected :: ParseTree -> Error ASTInfo unexpected :: ParseTree -> Error ASTInfo
@ -285,7 +281,7 @@ some p = some'
-- | Run parser on given file. -- | Run parser on given file.
-- --
runParser :: Parser a -> FilePath -> IO (a, [Error ASTInfo]) runParser :: Parser a -> FilePath -> IO (a, [Error ASTInfo])
runParser (Parser parser) fin = do runParser parser fin = do
pforest <- toParseTree fin pforest <- toParseTree fin
let let
res = res =
@ -293,6 +289,7 @@ runParser (Parser parser) fin = do
$ runExceptT $ runExceptT
$ flip runStateT (pforest, []) $ flip runStateT (pforest, [])
$ runWriterT $ runWriterT
$ unParser
$ parser $ parser
either (error . show) (return . fst) res either (error . show) (return . fst) res
@ -313,7 +310,7 @@ debugParser parser fin = do
token :: Text -> Parser Text token :: Text -> Parser Text
token node = do token node = do
i <- getInfo i <- getInfo
tree@ParseTree {ptName, ptSource} <- takeNext node ParseTree {ptName, ptSource} <- takeNext node
if ptName == node if ptName == node
then return ptSource then return ptSource
else die' node i else die' node i
@ -356,14 +353,14 @@ delete k ((k', v) : rest) =
else (addIfError v vs, addIfComment v cs, remains) else (addIfError v vs, addIfComment v cs, remains)
where where
(vs, cs, remains) = delete k rest (vs, cs, remains) = delete k rest
addIfError v = addIfError v' =
if ptName v == "ERROR" if ptName v' == "ERROR"
then (:) v then (:) v'
else id else id
addIfComment v = addIfComment v' =
if "comment" `Text.isSuffixOf` ptName v if "comment" `Text.isSuffixOf` ptName v'
then (ptSource v :) then (ptSource v' :)
else id else id
-- | Report all ERRORs from the list. -- | Report all ERRORs from the list.
@ -373,18 +370,6 @@ collectErrors vs =
when (ptName v == "ERROR") do when (ptName v == "ERROR") do
tell [unexpected v] 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. -- | Universal accessor.
-- --
-- Usage: -- Usage:

2
tools/lsp/squirrel/src/Pretty.hs
View File

@ -86,7 +86,7 @@ above a b = hang a 0 b
-- | Pretty print as a sequence with given separator. -- | Pretty print as a sequence with given separator.
train :: Pretty p => Doc -> [p] -> Doc 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. -- | Pretty print as a vertical block.
block :: Pretty p => [p] -> Doc block :: Pretty p => [p] -> Doc

2
tools/lsp/squirrel/src/Range.hs
View File

@ -7,8 +7,6 @@ module Range
) )
where where
import Control.Lens
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)

10
tools/lsp/squirrel/src/TH.hs
View File

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

4
tools/lsp/squirrel/src/Union.hs
View File

@ -66,11 +66,11 @@ instance Member f fs => Member f (g : fs) where
inj = There . inj inj = There . inj
proj = eliminate (const Nothing) proj 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" before = error "Union.empty"
after = 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 before = eliminate before before
after = eliminate after after after = eliminate after after

10
tools/lsp/squirrel/src/Update.hs
View File

@ -4,21 +4,15 @@
module Update module Update
( -- * Interfaces ( -- * Interfaces
HasMethods(..) UpdateOver(..)
, UpdateOver(..)
-- * Default implementation -- * Default implementation
, skip , skip
) )
where 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@. -- | 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 () before :: f a -> m ()
after :: f a -> m () after :: f a -> m ()