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

Add autocollector for comments

Browse Source
This commit is contained in:
Kirill Andreev 2020-05-08 21:30:19 +04:00
parent c497da5841
commit 19e1018620
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
4 changed files with 190 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -715,9 +715,9 @@ 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 = "../../../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"
-- example = "../../../src/test/contracts/application.ligo" -- example = "../../../src/test/contracts/application.ligo"
-- example = "../../../src/test/contracts/application.ligo" -- example = "../../../src/test/contracts/application.ligo"
-- example = "../../../src/test/contracts/application.ligo" -- example = "../../../src/test/contracts/application.ligo"

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

@ -212,33 +212,38 @@ data Name info = Name
instance Stubbed (Name info) where stub = WrongName instance Stubbed (Name info) where stub = WrongName
instance Show (Name info) where c :: HasComments i => i -> Doc -> Doc
c i d =
case getComments i of
[] -> d
cc -> vcat (map pp cc) $$ d
instance Show (Name i) where
show = \case show = \case
Name _ raw -> Text.unpack raw Name i raw -> Text.unpack raw
WrongName r -> "(Name? " ++ show r ++ ")" WrongName r -> "(Name? " ++ show r ++ ")"
instance Pretty (Contract i) where instance HasComments i => Pretty (Contract i) where
pp = \case pp = \case
Contract _ decls -> Contract i decls -> c i $
hang "(* contract *)" 2 do vcat $ punctuate "\n" $ map (($$ empty) . pp) decls
vcat $ punctuate "\n" $ map (($$ empty) . pp) decls
WrongContract err -> WrongContract err ->
pp err pp err
instance Pretty (Declaration i) where instance HasComments i => Pretty (Declaration i) where
pp = \case pp = \case
ValueDecl _ binding -> pp binding ValueDecl i binding -> c i $ pp binding
TypeDecl _ n ty -> hang ("type" <+> pp n <+> "=") 2 (pp ty) TypeDecl i n ty -> c i $ hang ("type" <+> pp n <+> "=") 2 (pp ty)
Action _ e -> pp e Action i e -> c i $ pp e
Include _ f -> "#include" <+> pp f Include i f -> c i $ "#include" <+> pp f
WrongDecl err -> pp err WrongDecl err -> pp err
instance Pretty (Binding i) where instance HasComments i => Pretty (Binding i) where
pp = \case pp = \case
Irrefutable _ pat expr -> error "irrefs in pascaligo?" Irrefutable i pat expr -> error "irrefs in pascaligo?"
Function _ isRec name params ty body -> Function i isRec name params ty body ->
hang c i $ hang
( fsep ( fsep
[ if isRec then "recursive" else empty [ if isRec then "recursive" else empty
, "function" , "function"
@ -251,22 +256,22 @@ instance Pretty (Binding i) where
) )
2 2
(pp body) (pp body)
Var _ name ty value -> Var i name ty value ->
hang c i $ hang
("var" <+> pp name <+> ":" <+> pp ty <+> ":=") ("var" <+> pp name <+> ":" <+> pp ty <+> ":=")
2 2
(pp value) (pp value)
Const _ name ty body -> Const i name ty body ->
hang c i $ hang
("const" <+> pp name <+> ":" <+> pp ty <+> "=") ("const" <+> pp name <+> ":" <+> pp ty <+> "=")
2 2
(pp body) (pp body)
WrongBinding err -> WrongBinding err ->
pp err pp err
instance Pretty (VarDecl i) where instance HasComments i => Pretty (VarDecl i) where
pp = \case pp = \case
Decl _ mutability name ty -> fsep Decl i mutability name ty -> c i $ fsep
[ pp mutability [ pp mutability
, pp name , pp name
, ":" , ":"
@ -275,130 +280,130 @@ instance Pretty (VarDecl i) where
WrongVarDecl err -> WrongVarDecl err ->
pp err pp err
instance Pretty (Mutable i) where instance HasComments i => Pretty (Mutable i) where
pp = \case pp = \case
Mutable _ -> "var" Mutable i -> c i $ "var"
Immutable _ -> "const" Immutable i -> c i $ "const"
WrongMutable err -> pp err WrongMutable err -> pp err
instance Pretty (Type i) where instance HasComments i => Pretty (Type i) where
pp = \case pp = \case
TArrow _ dom codom -> parens (pp dom <+> "->" <+> pp codom) TArrow i dom codom -> c i $ parens (pp dom <+> "->" <+> pp codom)
TRecord _ fields -> "record [" <> (vcat $ map pp fields) <> "]" TRecord i fields -> c i $ "record [" <> (vcat $ map pp fields) <> "]"
TVar _ name -> pp name TVar i name -> c i $ pp name
TSum _ variants -> vcat $ map pp variants TSum i variants -> c i $ vcat $ map pp variants
TProduct _ elements -> fsep $ punctuate " *" $ map pp elements TProduct i elements -> c i $ fsep $ punctuate " *" $ map pp elements
TApply _ f xs -> pp f <> parens (fsep $ punctuate "," $ map pp xs) TApply i f xs -> c i $ pp f <> parens (fsep $ punctuate "," $ map pp xs)
WrongType err -> pp err WrongType err -> pp err
where where
ppField (name, ty) = pp name <> ": " <> pp ty <> ";" ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
instance Pretty (Variant i) where instance HasComments i => Pretty (Variant i) where
pp = \case pp = \case
Variant _ ctor (Just ty) -> hang ("|" <+> pp ctor <+> "of") 2 (pp ty) Variant i ctor (Just ty) -> c i $ hang ("|" <+> pp ctor <+> "of") 2 (pp ty)
Variant _ ctor _ -> "|" <+> pp ctor Variant i ctor _ -> c i $ "|" <+> pp ctor
WrongVariant err -> pp err WrongVariant err -> pp err
-- My eyes. -- My eyes.
instance Pretty (Expr i) where instance HasComments i => Pretty (Expr i) where
pp = \case pp = \case
Let _ decls body -> "block {" $$ (nest 2 $ vcat $ punctuate "\n" $ map pp decls) $$ "}" $$ "with" $$ nest 2 (pp body) Let i decls body -> c i $ "block {" $$ (nest 2 $ vcat $ punctuate "\n" $ map pp decls) $$ "}" $$ "with" $$ nest 2 (pp body)
Apply _ f xs -> pp f <+> tuple xs Apply i f xs -> c i $ pp f <+> tuple xs
Constant _ constant -> pp constant Constant i constant -> c i $ pp constant
Ident _ qname -> pp qname Ident i qname -> c i $ pp qname
BinOp _ l o r -> parens (pp l <+> pp o <+> pp r) BinOp i l o r -> c i $ parens (pp l <+> pp o <+> pp r)
UnOp _ o r -> parens (pp o <+> pp r) UnOp i o r -> c i $ parens (pp o <+> pp r)
Record _ az -> "record [" <> (fsep $ punctuate ";" $ map pp az) <> "]" Record i az -> c i $ "record [" <> (fsep $ punctuate ";" $ map pp az) <> "]"
If _ b t e -> fsep ["if" <+> pp b, hang "then" 2 $ pp t, hang "else" 2 $ pp e] If i b t e -> c i $ fsep ["if" <+> pp b, hang "then" 2 $ pp t, hang "else" 2 $ pp e]
Assign _ l r -> hang (pp l <+> ":=") 2 (pp r) Assign i l r -> c i $ hang (pp l <+> ":=") 2 (pp r)
List _ l -> "list [" <> fsep (punctuate ";" $ map pp l) <> "]" List i l -> c i $ "list [" <> fsep (punctuate ";" $ map pp l) <> "]"
Set _ l -> "set [" <> fsep (punctuate ";" $ map pp l) <> "]" Set i l -> c i $ "set [" <> fsep (punctuate ";" $ map pp l) <> "]"
Tuple _ l -> "(" <> fsep (punctuate "," $ map pp l) <> ")" Tuple i l -> c i $ "(" <> fsep (punctuate "," $ map pp l) <> ")"
Annot _ n t -> ("(" <> pp n) <+> ":" <+> (pp t <> ")") Annot i n t -> c i $ ("(" <> pp n) <+> ":" <+> (pp t <> ")")
Attrs _ ts -> "attributes [" <> fsep (punctuate ";" $ map pp ts) <> "]" Attrs i ts -> c i $ "attributes [" <> fsep (punctuate ";" $ map pp ts) <> "]"
BigMap _ bs -> "big_map [" <> fsep (punctuate ";" $ map pp bs) <> "]" BigMap i bs -> c i $ "big_map [" <> fsep (punctuate ";" $ map pp bs) <> "]"
Map _ bs -> "map [" <> fsep (punctuate ";" $ map pp bs) <> "]" Map i bs -> c i $ "map [" <> fsep (punctuate ";" $ map pp bs) <> "]"
MapRemove _ k m -> hang ("remove" <+> pp k) 0 ("from" <+> "map" <+> pp m) MapRemove i k m -> c i $ hang ("remove" <+> pp k) 0 ("from" <+> "map" <+> pp m)
SetRemove _ k s -> hang ("remove" <+> pp k) 0 ("from" <+> "set" <+> pp s) SetRemove i k s -> c i $ hang ("remove" <+> pp k) 0 ("from" <+> "set" <+> pp s)
Indexing _ a i -> pp a <> brackets (pp i) Indexing i a j -> c i $ pp a <> brackets (pp j)
Case _ s az -> hang ("case" <+> pp s <+> "of") 2 (vcat $ map pp az) Case i s az -> c i $ hang ("case" <+> pp s <+> "of") 2 (vcat $ map pp az)
Skip _ -> "skip" Skip i -> c i $ "skip"
ForLoop _ i s f b -> hang ("for" <+> pp i <+> ":=" <+> pp s <+> "to" <+> pp f) 2 (pp b) ForLoop i j s f b -> c i $ hang ("for" <+> pp j <+> ":=" <+> pp s <+> "to" <+> pp f) 2 (pp b)
ForBox _ k mv t c b -> hang ("for" <+> (pp k <> maybe empty ((" ->" <+>) . pp) mv) <+> "in" <+> pp t <+> pp c) 2 (pp b) ForBox i k mv t z b -> c i $ hang ("for" <+> (pp k <> maybe empty ((" ->" <+>) . pp) mv) <+> "in" <+> pp t <+> pp z) 2 (pp b)
WhileLoop _ f b -> hang ("while" <+> pp f) 2 (pp b) WhileLoop i f b -> c i $ hang ("while" <+> pp f) 2 (pp b)
Seq _ es -> hang (hang "block {" 2 (vcat $ map pp es)) 0 "}" Seq i es -> c i $ hang (hang "block {" 2 (vcat $ map pp es)) 0 "}"
Lambda _ ps ty b -> parens (hang ("function" <+> ("(" <> fsep (punctuate "," $ map pp ps) <> ") :") <+> pp ty) 2 (pp b)) Lambda i ps ty b -> c i $ parens (hang ("function" <+> ("(" <> fsep (punctuate "," $ map pp ps) <> ") :") <+> pp ty) 2 (pp b))
MapPatch _ c bs -> hang (hang "patch" 2 (pp c)) 0 (hang ("with" <+> "map") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]")) MapPatch i z bs -> c i $ hang (hang "patch" 2 (pp z)) 0 (hang ("with" <+> "map") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]"))
SetPatch _ c bs -> hang (hang "patch" 2 (pp c)) 0 (hang ("with" <+> "set") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]")) SetPatch i z bs -> c i $ hang (hang "patch" 2 (pp z)) 0 (hang ("with" <+> "set") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]"))
RecordUpd _ r up -> hang (pp r) 2 (hang ("with" <+> "record") 2 ("[" <> fsep (punctuate ";" $ map pp up) <> "]")) RecordUpd i r up -> c i $ hang (pp r) 2 (hang ("with" <+> "record") 2 ("[" <> fsep (punctuate ";" $ map pp up) <> "]"))
WrongExpr err -> pp err WrongExpr err -> pp err
instance Pretty (Alt info) where instance HasComments i => Pretty (Alt i) where
pp = \case pp = \case
Alt _ p b -> hang ("|" <+> pp p <+> "->") 2 (pp b) Alt i p b -> c i $ hang ("|" <+> pp p <+> "->") 2 (pp b)
WrongAlt err -> pp err WrongAlt err -> pp err
instance Pretty (MapBinding i) where instance HasComments i => Pretty (MapBinding i) where
pp = \case pp = \case
MapBinding _ k v -> hang (pp k <+> "->") 2 (pp v) MapBinding i k v -> c i $ hang (pp k <+> "->") 2 (pp v)
WrongMapBinding err -> pp err WrongMapBinding err -> pp err
instance Pretty (Assignment i) where instance HasComments i => Pretty (Assignment i) where
pp = \case pp = \case
Assignment _ n e -> pp n <+> "=" <+> pp e Assignment i n e -> c i $ pp n <+> "=" <+> pp e
WrongAssignment err -> pp err WrongAssignment err -> pp err
instance Pretty (FieldAssignment i) where instance HasComments i => Pretty (FieldAssignment i) where
pp = \case pp = \case
FieldAssignment _ n e -> pp n <+> "=" <+> pp e FieldAssignment i n e -> c i $ pp n <+> "=" <+> pp e
WrongFieldAssignment err -> pp err WrongFieldAssignment err -> pp err
instance Pretty (Constant i) where instance HasComments i => Pretty (Constant i) where
pp = \case pp = \case
Int _ c -> pp c Int i z -> c i $ pp z
Nat _ c -> pp c Nat i z -> c i $ pp z
String _ c -> pp c String i z -> c i $ pp z
Float _ c -> pp c Float i z -> c i $ pp z
Bytes _ c -> pp c Bytes i z -> c i $ pp z
Tez _ c -> pp c Tez i z -> c i $ pp z
WrongConstant err -> pp err WrongConstant err -> pp err
instance Pretty (QualifiedName i) where instance HasComments i => Pretty (QualifiedName i) where
pp = \case pp = \case
QualifiedName _ src path -> pp src <> cat (map (("." <>) . pp) path) QualifiedName i src path -> c i $ pp src <> cat (map (("." <>) . pp) path)
WrongQualifiedName err -> pp err WrongQualifiedName err -> pp err
instance Pretty (Pattern info) where instance HasComments i => Pretty (Pattern i) where
pp = \case pp = \case
IsConstr _ ctor arg -> pp ctor <> maybe empty pp arg IsConstr i ctor arg -> c i $ pp ctor <> maybe empty pp arg
IsConstant _ c -> pp c IsConstant i z -> c i $ pp z
IsVar _ name -> pp name IsVar i name -> c i $ pp name
IsCons _ h t -> pp h <+> "#" <+> pp t IsCons i h t -> c i $ pp h <+> "#" <+> pp t
IsWildcard _ -> "_" IsWildcard i -> c i $ "_"
IsList _ l -> "[" <> fsep (punctuate ";" $ map pp l) <> "]" IsList i l -> c i $ "[" <> fsep (punctuate ";" $ map pp l) <> "]"
IsTuple _ t -> "(" <> fsep (punctuate "," $ map pp t) <> ")" IsTuple i t -> c i $ "(" <> fsep (punctuate "," $ map pp t) <> ")"
WrongPattern err -> pp err WrongPattern err -> pp err
instance Pretty (Name i) where instance HasComments i => Pretty (Name i) where
pp = \case pp = \case
Name _ raw -> pp raw Name i raw -> c i $ pp raw
WrongName err -> pp err WrongName err -> pp err
instance Pretty (Path i) where instance HasComments i => Pretty (Path i) where
pp = \case pp = \case
At _ n -> pp n At i n -> c i $ pp n
Ix _ i -> pp i Ix i j -> c i $ pp j
WrongPath err -> pp err WrongPath err -> pp err
instance Pretty (TField i) where instance HasComments i => Pretty (TField i) where
pp = \case pp = \case
TField _ n t -> hang (pp n <> ":") 2 (pp t) TField i n t -> c i $ hang (pp n <> ":") 2 (pp t)
WrongTField err -> pp err WrongTField err -> pp err
instance Pretty (LHS i) where instance HasComments i => Pretty (LHS i) where
pp = \case pp = \case
LHS _ qn mi -> pp qn <> foldMap (brackets . pp) mi LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi
WrongLHS err -> pp err WrongLHS err -> pp err
-- TODO: Use it, make more alike. -- TODO: Use it, make more alike.

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

@ -47,8 +47,8 @@ data ParseTree = ParseTree
{ ptID :: Int -- ^ Unique number, for fast comparison. { ptID :: Int -- ^ Unique number, for fast comparison.
, ptName :: Text -- ^ Name of the node. , ptName :: Text -- ^ Name of the node.
, ptRange :: Range -- ^ Range of the node. , ptRange :: Range -- ^ Range of the node.
, ptSource :: ~Text -- ^ Range of the node.
, ptChildren :: ParseForest -- ^ Subtrees. , ptChildren :: ParseForest -- ^ Subtrees.
, ptSource :: ~Text -- ^ Range of the node.
} }
deriving (Show) via PP ParseTree deriving (Show) via PP ParseTree

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

@ -74,17 +74,17 @@ instance Pretty Error where
-- | Parser of tree-sitter-made tree. -- | Parser of tree-sitter-made tree.
newtype Parser a = Parser newtype Parser a = Parser
{ unParser { unParser
:: WriterT [Error] -- Early I though to report errors that way. :: WriterT [Error] -- Early I though to report errors that way.
( StateT ParseForest -- Current forest to recognise. ( StateT (ParseForest, [Text]) -- Current forest to recognise + comments.
( ExceptT Error -- Backtracking. Change `Error` to `()`? ( ExceptT Error -- Backtracking. Change `Error` to `()`?
( Identity ))) -- I forgot why. `#include`? Debug via `print`? ( Identity ))) -- I forgot why. `#include`? Debug via `print`?
a a
} }
deriving newtype deriving newtype
( Functor ( Functor
, Applicative , Applicative
, Monad , Monad
, MonadState ParseForest , MonadState (ParseForest, [Text])
, MonadWriter [Error] , MonadWriter [Error]
, MonadError Error , MonadError Error
) )
@ -99,7 +99,7 @@ makeError msg = do
makeError' :: Text -> Range -> Parser Error makeError' :: Text -> Range -> Parser Error
makeError' msg rng = do makeError' msg rng = do
rng <- getRange rng <- getRange
src <- gets pfGrove <&> \case src <- gets (pfGrove . fst) <&> \case
[] -> "" [] -> ""
(,) _ ParseTree { ptSource } : _ -> ptSource (,) _ ParseTree { ptSource } : _ -> ptSource
return Expected return Expected
@ -111,15 +111,24 @@ makeError' msg rng = do
-- | Pick next tree in a forest or die with msg. -- | Pick next tree in a forest or die with msg.
takeNext :: Text -> Parser ParseTree takeNext :: Text -> Parser ParseTree
takeNext msg = do takeNext msg = do
st@Forest {pfGrove, pfRange} <- get (st@Forest {pfGrove, pfRange}, comms) <- get
case pfGrove of case pfGrove of
[] -> die msg [] -> die msg
(_, t) : f -> do (_, t) : f -> do
put st if "comment" `Text.isSuffixOf` ptName t
{ pfRange = diffRange pfRange (ptRange t) then do
, pfGrove = f (st, comms) <- get
} put (st, ptSource t : comms)
return t takeNext msg
else do
put
( st
{ pfRange = diffRange pfRange (ptRange t)
, pfGrove = f
}
, comms
)
return t
-- | Pick a tree with that /field name/ or die with name as msg. -- | Pick a tree with that /field name/ or die with name as msg.
-- --
@ -127,7 +136,7 @@ takeNext msg = do
-- --
field :: Text -> Parser a -> Parser a field :: Text -> Parser a -> Parser a
field name parser = do field name parser = do
grove <- gets pfGrove grove <- gets (pfGrove . fst)
case grove of case grove of
(name', t) : _ (name', t) : _
| name == name' -> do | name == name' -> do
@ -140,20 +149,26 @@ field name parser = do
where where
sandbox firstOne tree@ParseTree {ptID, ptRange} = do sandbox firstOne tree@ParseTree {ptID, ptRange} = do
st@Forest {pfGrove = grove, pfRange = rng} <- get (st@Forest {pfGrove = grove, pfRange = rng}, comments) <- get
let (errs, grove') = delete name grove let (errs, new_comments, grove') = delete name grove
put Forest put
{ pfID = ptID ( Forest
, pfGrove = [(name, tree)] { pfID = ptID
, pfRange = ptRange , pfGrove = [(name, tree)]
} , pfRange = ptRange
}
, comments ++ new_comments
)
res <- parser res <- parser
put st put
{ pfGrove = grove' ( st
, pfRange = if firstOne then diffRange rng ptRange else rng { pfGrove = grove'
} , pfRange = if firstOne then diffRange rng ptRange else rng
}
, []
)
for_ errs (tell . pure . unexpected) for_ errs (tell . pure . unexpected)
@ -187,11 +202,12 @@ subtree msg parser = do
ParseTree {ptChildren, ptName} <- takeNext msg ParseTree {ptChildren, ptName} <- takeNext msg
if ptName == msg if ptName == msg
then do then do
save <- get (save, comms) <- get
put ptChildren put (ptChildren, comms)
rest <- gets pfGrove rest <- gets (pfGrove . fst)
collectErrors rest collectErrors rest
parser <* put save (_, comms') <- get
parser <* put (save, comms')
else do else do
die msg die msg
@ -229,8 +245,6 @@ some p = some'
-- | Run parser on given file. -- | Run parser on given file.
-- --
-- TODO: invent /proper/ 'ERROR'-node collector.
--
runParser :: Parser a -> FilePath -> IO (a, [Error]) runParser :: Parser a -> FilePath -> IO (a, [Error])
runParser (Parser parser) fin = do runParser (Parser parser) fin = do
pforest <- toParseTree fin pforest <- toParseTree fin
@ -238,13 +252,14 @@ runParser (Parser parser) fin = do
res = res =
runIdentity runIdentity
$ runExceptT $ runExceptT
$ flip runStateT pforest $ flip runStateT (pforest, [])
$ runWriterT $ runWriterT
$ parser $ parser
either (error . show) (return . fst) res either (error . show) (return . fst) res
-- | Run parser on given file and pretty-print stuff. -- | Run parser on given file and pretty-print stuff.
--
debugParser :: Show a => Parser a -> FilePath -> IO () debugParser :: Show a => Parser a -> FilePath -> IO ()
debugParser parser fin = do debugParser parser fin = do
(res, errs) <- runParser parser fin (res, errs) <- runParser parser fin
@ -273,11 +288,11 @@ anything = do
range :: Parser a -> Parser (a, Range) range :: Parser a -> Parser (a, Range)
range parser = range parser =
get >>= \case get >>= \case
Forest {pfGrove = (,) _ ParseTree {ptRange} : _} -> do (,) Forest {pfGrove = (,) _ ParseTree {ptRange} : _} _ -> do
a <- parser a <- parser
return (a, ptRange) return (a, ptRange)
Forest {pfRange} -> do (,) Forest {pfRange} _ -> do
a <- parser a <- parser
return (a, pfRange) return (a, pfRange)
@ -287,22 +302,31 @@ getRange = snd <$> range (return ())
-- | Remove all keys until given key is found; remove the latter as well. -- | Remove all keys until given key is found; remove the latter as well.
-- --
-- Also returns all ERROR-nodes.
--
-- TODO: rename.
--
-- Notice: this works differently from `Prelude.remove`! -- Notice: this works differently from `Prelude.remove`!
-- --
delete :: Text -> [(Text, ParseTree)] -> ([ParseTree], [(Text, ParseTree)]) delete :: Text -> [(Text, ParseTree)] -> ([ParseTree], [Text], [(Text, ParseTree)])
delete _ [] = ([], []) delete _ [] = ([], [], [])
delete k ((k', v) : rest) = delete k ((k', v) : rest) =
if k == k' if k == k'
then (addIfError v [], rest) then (addIfError v [], addIfComment v [], rest)
else (addIfError v vs, remains) else (addIfError v vs, addIfComment v cs, remains)
where where
(vs, remains) = delete k rest (vs, cs, remains) = delete k rest
addIfError v =
if ptName v == "ERROR"
then (:) v
else id
addIfError v = addIfComment v =
if ptName v == "ERROR" if "comment" `Text.isSuffixOf` ptName v
then (:) v then (ptSource v :)
else id else id
-- | Report all ERRORs from the list.
collectErrors :: [(Text, ParseTree)] -> Parser () collectErrors :: [(Text, ParseTree)] -> Parser ()
collectErrors vs = collectErrors vs =
for_ vs \(_, v) -> do for_ vs \(_, v) -> do
@ -330,7 +354,8 @@ instance Stubbed Text where
-- | This is bad, but I had to. -- | This is bad, but I had to.
-- --
-- TODO: find a way to remove this instance. -- TODO: Find a way to remove this instance.
-- I probably need a wrapper around '[]'.
-- --
instance Stubbed [a] where instance Stubbed [a] where
stub _ = [] stub _ = []
@ -373,10 +398,22 @@ data ASTInfo = ASTInfo
, aiComments :: [Text] , aiComments :: [Text]
} }
class HasComments c where
getComments :: c -> [Text]
instance HasComments ASTInfo where
getComments = aiComments
-- | Equip given constructor with info. -- | Equip given constructor with info.
ctor :: (ASTInfo -> a) -> Parser a ctor :: (ASTInfo -> a) -> Parser a
ctor = (<$> (ASTInfo <$> getRange <*> pure [])) ctor = (<$> (ASTInfo <$> getRange <*> grabComments))
grabComments :: Parser [Text]
grabComments = do
(st, comms) <- get
put (st, [])
return comms
-- | /Actual/ debug pring. -- | /Actual/ debug pring.
dump :: Parser () dump :: Parser ()
dump = gets pfGrove >>= traceShowM dump = gets (pfGrove . fst) >>= traceShowM