Remove debug print, document Parser.hs
This commit is contained in:
Kirill Andreev
parent
e6299a50ff
commit
eace901195
@ -48,7 +48,6 @@ typedecl = do
|
||||
vardecl :: Parser (Binding ASTInfo)
|
||||
vardecl = do
|
||||
subtree "var_decl" do
|
||||
dump
|
||||
ctor Var
|
||||
<*> inside "name" name
|
||||
<*> inside "type" type_
|
||||
@ -179,7 +178,6 @@ lambda_expr = do
|
||||
|
||||
seq_expr = do
|
||||
subtree "block" do
|
||||
dump
|
||||
ctor Seq <*> do
|
||||
many "statement" do
|
||||
inside "statement" do
|
||||
@ -229,7 +227,6 @@ skip = do
|
||||
case_action :: Parser (Expr ASTInfo)
|
||||
case_action = do
|
||||
subtree "case_instr" do
|
||||
dump
|
||||
ctor Case
|
||||
<*> inside "subject" expr
|
||||
<*> many "case" do
|
||||
|
||||
@ -39,24 +39,22 @@ foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
|
||||
getNodeTypesPath :: IO FilePath
|
||||
getNodeTypesPath = getDataFileName "../pascaligo/src/node-types.json"
|
||||
|
||||
-- | The tree tree-sitter produces.
|
||||
data ParseTree = ParseTree
|
||||
{ ptID :: Int
|
||||
, ptName :: Text.Text
|
||||
, ptRange :: Range
|
||||
, ptChildren :: ParseForest
|
||||
{ ptID :: Int -- ^ Unique number, for fast comparison.
|
||||
, ptName :: Text.Text -- ^ Name of the node.
|
||||
, ptRange :: Range -- ^ Range of the node.
|
||||
, ptChildren :: ParseForest -- ^ Subtrees.
|
||||
}
|
||||
deriving (Show) via PP ParseTree
|
||||
|
||||
-- ^ The forest we work with.
|
||||
data ParseForest = Forest
|
||||
{ pfID :: Int
|
||||
, pfGrove :: [(Text.Text, ParseTree)]
|
||||
, pfRange :: Range
|
||||
{ pfID :: Int -- ^ Unique number for comparison.
|
||||
, pfGrove :: [(Text.Text, ParseTree)] -- ^ Subtrees.
|
||||
, pfRange :: Range -- ^ Full range of the forest.
|
||||
}
|
||||
|
||||
instance Show ParseTree where
|
||||
show = show . pp
|
||||
|
||||
instance Show ParseForest where
|
||||
show = show . pp
|
||||
deriving (Show) via PP ParseForest
|
||||
|
||||
instance Pretty ParseTree where
|
||||
pp (ParseTree _ n r forest) =
|
||||
@ -75,6 +73,7 @@ instance Pretty ParseForest where
|
||||
then nest 2 $ pp tree
|
||||
else hang (text (Text.unpack field) <> ": ") 2 (pp tree)
|
||||
|
||||
-- | Feed file contents into PascaLIGO grammar recogniser.
|
||||
toParseTree :: FilePath -> IO ParseForest
|
||||
toParseTree fin = do
|
||||
parser <- ts_parser_new
|
||||
|
||||
@ -21,24 +21,26 @@ import Pretty
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
-- | Parse error.
|
||||
data Error
|
||||
= Expected
|
||||
{ eMsg :: Text
|
||||
, eWhole :: Text
|
||||
, eRange :: Range
|
||||
{ eMsg :: Text -- ^ Description of what was expected.
|
||||
, eWhole :: Text -- ^ Offending text.
|
||||
, eRange :: Range -- ^ Location of the error.
|
||||
}
|
||||
deriving stock (Show)
|
||||
deriving (Show) via PP Error
|
||||
|
||||
instance Pretty Error where
|
||||
pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓"
|
||||
|
||||
-- | Parser of tree-sitter-made tree.
|
||||
newtype Parser a = Parser
|
||||
{ unParser
|
||||
:: WriterT [Error]
|
||||
( ReaderT ParserEnv
|
||||
( StateT ParseForest
|
||||
( ExceptT Error
|
||||
( IO ))))
|
||||
:: WriterT [Error] -- Early I though to report errors that way. Obs.
|
||||
( ReaderT ParserEnv -- Range/Something.
|
||||
( StateT ParseForest -- Current forest to recognise.
|
||||
( ExceptT Error -- Backtracking. Change `Error` to `()`?
|
||||
( IO )))) -- I forgot why. `#include`? Debug via `print`?
|
||||
a
|
||||
}
|
||||
deriving newtype
|
||||
@ -52,11 +54,13 @@ newtype Parser a = Parser
|
||||
, MonadIO
|
||||
)
|
||||
|
||||
-- | Generate error originating at current location.
|
||||
makeError :: Text -> Parser Error
|
||||
makeError msg = do
|
||||
rng <- getRange
|
||||
makeError' msg rng
|
||||
|
||||
-- | Generate error originating at given location.
|
||||
makeError' :: Text -> Range -> Parser Error
|
||||
makeError' msg rng = do
|
||||
rng <- getRange
|
||||
@ -67,6 +71,7 @@ makeError' msg rng = do
|
||||
, eRange = rng
|
||||
}
|
||||
|
||||
-- | Pick next tree in a forest or die with msg.
|
||||
takeNext :: Text -> Parser ParseTree
|
||||
takeNext msg = do
|
||||
st@Forest {pfGrove, pfRange} <- get
|
||||
@ -79,6 +84,10 @@ takeNext msg = do
|
||||
}
|
||||
return t
|
||||
|
||||
-- | Pick a tree with that /field name/ or die with name as msg.
|
||||
--
|
||||
-- Will erase all subtrees with different names on the path!
|
||||
--
|
||||
field :: Text -> Parser a -> Parser a
|
||||
field name parser = do
|
||||
grove <- gets pfGrove
|
||||
@ -107,6 +116,7 @@ field name parser = do
|
||||
, pfRange = if firstOne then diffRange rng ptRange else rng
|
||||
}
|
||||
|
||||
-- | Variuos error reports.
|
||||
fallback :: Stubbed a => Text -> Parser a
|
||||
fallback' :: Stubbed a => Text -> Range -> Parser a
|
||||
die :: Text -> Parser a
|
||||
@ -118,10 +128,13 @@ die msg = throwError =<< makeError msg
|
||||
die' msg rng = throwError =<< makeError' msg rng
|
||||
complain msg rng = tell . pure =<< makeError' msg rng
|
||||
|
||||
-- | If a parser fails, return stub with error originating here.
|
||||
stubbed :: Stubbed a => Text -> Parser a -> Parser a
|
||||
stubbed msg parser = do
|
||||
parser <|> fallback msg
|
||||
|
||||
-- | The forest must start with tree of that name. Its subtrees become new
|
||||
-- forest. Otherwise, it dies with name as msg.
|
||||
subtree :: Text -> Parser a -> Parser a
|
||||
subtree msg parser = do
|
||||
ParseTree {ptChildren, ptName} <- takeNext msg
|
||||
@ -133,6 +146,7 @@ subtree msg parser = do
|
||||
else do
|
||||
die msg
|
||||
|
||||
-- | Because `ExceptT` requires error to be `Monoid` for `Alternative`.
|
||||
(<|>) :: Parser a -> Parser a -> Parser a
|
||||
Parser l <|> Parser r = Parser (l `catchError` const r)
|
||||
|
||||
@ -142,6 +156,10 @@ select = foldl1 (<|>)
|
||||
optional :: Parser a -> Parser (Maybe a)
|
||||
optional p = fmap Just p <|> return Nothing
|
||||
|
||||
-- | Custom `Alternative.many`.
|
||||
--
|
||||
-- TODO: remove msg.
|
||||
--
|
||||
many :: Text -> Parser a -> Parser [a]
|
||||
many msg p = many'
|
||||
where
|
||||
@ -155,6 +173,10 @@ many msg p = many'
|
||||
else do
|
||||
return [x]
|
||||
|
||||
-- | Custom `Alternative.some`.
|
||||
--
|
||||
-- TODO: remove msg.
|
||||
--
|
||||
some :: Text -> Parser a -> Parser [a]
|
||||
some msg p = some'
|
||||
where
|
||||
@ -168,12 +190,20 @@ some msg p = some'
|
||||
else do
|
||||
return [x]
|
||||
|
||||
-- | Get UID of current tree. Obsolete.
|
||||
--
|
||||
-- TODO: remove.
|
||||
--
|
||||
getTreeID :: Parser (Maybe Int)
|
||||
getTreeID = Parser do
|
||||
pfGrove <$> get >>= return . \case
|
||||
[] -> Nothing
|
||||
(_, tree) : _ -> Just (ptID tree)
|
||||
|
||||
-- | Assert the parser consumes input. Obsolete.
|
||||
--
|
||||
-- TODO: remove.
|
||||
--
|
||||
productive :: Parser a -> Parser (a, Bool)
|
||||
productive p = do
|
||||
was <- getTreeID
|
||||
@ -181,19 +211,33 @@ productive p = do
|
||||
now <- getTreeID
|
||||
return (res, was /= now)
|
||||
|
||||
-- | The `not <$> eos`. Obsolete.
|
||||
--
|
||||
-- TODO: remove.
|
||||
--
|
||||
hasPossibleInput :: Parser ()
|
||||
hasPossibleInput = do
|
||||
yes <- gets (not . null . pfGrove)
|
||||
unless yes do
|
||||
die "something"
|
||||
|
||||
-- | The source of file being parsed. BS, because tree-sitter has offsets
|
||||
-- in /bytes/.
|
||||
data ParserEnv = ParserEnv
|
||||
{ peSource :: ByteString
|
||||
}
|
||||
|
||||
-- | Debug print via IO. Obsolete.
|
||||
--
|
||||
-- TODO: remove. Also, remove IO from Parser tf stack.
|
||||
--
|
||||
puts :: MonadIO m => Show a => a -> m ()
|
||||
puts = liftIO . print
|
||||
|
||||
-- | Run parser on given file.
|
||||
--
|
||||
-- TODO: invent /proper/ 'ERROR'-node collector.
|
||||
--
|
||||
runParser :: Parser a -> FilePath -> IO (a, [Error])
|
||||
runParser (Parser parser) fin = do
|
||||
pforest <- toParseTree fin
|
||||
@ -207,6 +251,7 @@ runParser (Parser parser) fin = do
|
||||
|
||||
either (error . show) (return . fst) res
|
||||
|
||||
-- | Run parser on given file and pretty-print stuff.
|
||||
debugParser :: Parser a -> FilePath -> IO a
|
||||
debugParser parser fin = do
|
||||
(res, errs) <- runParser parser fin
|
||||
@ -216,6 +261,7 @@ debugParser parser fin = do
|
||||
putStrLn "Result:"
|
||||
return res
|
||||
|
||||
-- | Consume next tree if it has give name. Or die.
|
||||
token :: Text -> Parser Text
|
||||
token node = do
|
||||
tree@ParseTree {ptName, ptRange} <- takeNext node
|
||||
@ -226,28 +272,33 @@ token node = do
|
||||
else do
|
||||
die' node ptRange
|
||||
|
||||
-- | Consume next tree, return its textual representation.
|
||||
anything :: Parser Text
|
||||
anything = do
|
||||
tree <- takeNext "anything"
|
||||
cutOut $ ptRange tree
|
||||
|
||||
-- | TODO: remove, b/c obsolete.
|
||||
consume :: Text -> Parser ()
|
||||
consume node = do
|
||||
ParseTree {ptName, ptRange} <- takeNext node
|
||||
when (ptName /= node) do
|
||||
complain node ptRange
|
||||
|
||||
-- | TODO: remove, its literally is `void . token`.
|
||||
consumeOrDie :: Text -> Parser ()
|
||||
consumeOrDie node = do
|
||||
ParseTree {ptName, ptRange} <- takeNext node
|
||||
when (ptName /= node) do
|
||||
die' node ptRange
|
||||
|
||||
-- | Extract textual representation of given range.
|
||||
cutOut :: Range -> Parser Text
|
||||
cutOut (Range (_, _, s) (_, _, f)) = do
|
||||
bs <- asks peSource
|
||||
return $ decodeUtf8 $ ByteString.take (f - s) (ByteString.drop s bs)
|
||||
|
||||
-- | Get range of current tree or forest before the parser was run.
|
||||
range :: Parser a -> Parser (a, Range)
|
||||
range parser =
|
||||
get >>= \case
|
||||
@ -259,9 +310,14 @@ range parser =
|
||||
a <- parser
|
||||
return (a, pfRange)
|
||||
|
||||
-- | Get current range.
|
||||
getRange :: Parser Range
|
||||
getRange = snd <$> range (return ())
|
||||
|
||||
-- | Remove all keys until given key is found; remove the latter as well.
|
||||
--
|
||||
-- Notice: this works differently from `Prelude.remove`!
|
||||
--
|
||||
delete :: Eq k => k -> [(k, v)] -> [(k, v)]
|
||||
delete _ [] = []
|
||||
delete k ((k', v) : rest) =
|
||||
@ -269,6 +325,7 @@ delete k ((k', v) : rest) =
|
||||
then rest
|
||||
else delete k rest
|
||||
|
||||
-- | Parser negation.
|
||||
notFollowedBy :: Parser a -> Parser ()
|
||||
notFollowedBy parser = do
|
||||
good <- do
|
||||
@ -280,24 +337,39 @@ notFollowedBy parser = do
|
||||
unless good do
|
||||
die "notFollowedBy"
|
||||
|
||||
-- | For types that have a default replacer with an `Error`.
|
||||
class Stubbed a where
|
||||
stub :: Error -> a
|
||||
|
||||
instance Stubbed Text where
|
||||
stub = pack . show
|
||||
|
||||
-- | This is bad, but I had to.
|
||||
--
|
||||
-- TODO: find a way to remove this instance.
|
||||
--
|
||||
instance Stubbed [a] where
|
||||
stub _ = []
|
||||
|
||||
-- | `Nothing` would be bad default replacer.
|
||||
instance Stubbed a => Stubbed (Maybe a) where
|
||||
stub = Just . stub
|
||||
|
||||
-- | Universal accessor.
|
||||
--
|
||||
-- Usage:
|
||||
--
|
||||
-- > inside "$field:$treename"
|
||||
-- > inside "$field"
|
||||
-- > inside ":$treename" -- don't, use "subtree"
|
||||
--
|
||||
inside :: Stubbed a => Text -> Parser a -> Parser a
|
||||
inside sig parser = do
|
||||
let (f, st') = Text.breakOn ":" sig
|
||||
let st = Text.drop 1 st'
|
||||
if Text.null f
|
||||
then do
|
||||
-- The order is important.
|
||||
subtree st do
|
||||
stubbed f do
|
||||
parser
|
||||
@ -311,13 +383,16 @@ inside sig parser = do
|
||||
subtree st do
|
||||
parser
|
||||
|
||||
-- Auto-accumulated information to be fed into AST being build.
|
||||
data ASTInfo = ASTInfo
|
||||
{ aiRange :: Range
|
||||
, aiComments :: [Text]
|
||||
}
|
||||
|
||||
-- | Equip given constructor with info.
|
||||
ctor :: (ASTInfo -> a) -> Parser a
|
||||
ctor = (<$> (ASTInfo <$> getRange <*> pure []))
|
||||
|
||||
-- | /Actual/ debug pring.
|
||||
dump :: Parser ()
|
||||
dump = gets pfGrove >>= traceShowM
|
||||
|
||||
Loading…
Reference in New Issue
Block a user