diff --git a/simple-parser.cabal b/simple-parser.cabal --- a/simple-parser.cabal +++ b/simple-parser.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 180d046a2a3f8dc8692f2667efbbe7f11bbf34969c2e11daa7abb119b50517bb +-- hash: cfc5b1cb72599e6ff1fdcda8ef9bca96a91c3fb347c172a0bcf61c9fd18f7e48 name: simple-parser -version: 0.11.0 +version: 0.12.0 synopsis: Simple parser combinators description: Please see the README on GitHub at category: Parsing @@ -60,6 +60,7 @@ DeriveFoldable DeriveTraversable DerivingStrategies + DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies @@ -99,6 +100,7 @@ DeriveFoldable DeriveTraversable DerivingStrategies + DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies diff --git a/src/SimpleParser/Errata.hs b/src/SimpleParser/Errata.hs --- a/src/SimpleParser/Errata.hs +++ b/src/SimpleParser/Errata.hs @@ -11,14 +11,15 @@ import Data.Sequence (Seq (..)) import qualified Data.Text as T import Errata (Block, PointerStyle, Style, blockMerged') -import SimpleParser.Explain (ErrorExplanation (..), Explainable, ParseErrorExplanation (..), explainParseError) +import SimpleParser.Explain (ErrorExplanation (..), Explainable, ParseErrorExplanation (..), TextBuildable, + explainParseError) import SimpleParser.Result (ParseError, ParseErrorBundle (ParseErrorBundle), ParseResult (..)) -import SimpleParser.Stream (Col (..), HasLinePos (..), Line (..), Pos, Span (..)) +import SimpleParser.Stream (Col (..), HasLinePos (..), Line (..), Pos, Span (..), Stream (Chunk, Token)) -type LinePosExplainable l s e = (Explainable l s e, HasLinePos (Pos s)) +type LinePosExplainable l s e = (Explainable l s e, HasLinePos (Pos s), TextBuildable (Token s), TextBuildable (Chunk s)) errataExplanation :: HasLinePos p => Style -> PointerStyle -> FilePath -> ParseErrorExplanation p -> Block -errataExplanation bsty psty fp (ParseErrorExplanation sp context mayDetails (ErrorExplanation reason mayExpected mayActual)) = +errataExplanation bsty psty fp (ParseErrorExplanation sp context mayDetails (ErrorExplanation reason mayExpected mayActual)) = let Span startPos endPos = sp startLine = unLine (viewLine startPos) startCol = unCol (viewCol startPos) diff --git a/src/SimpleParser/Examples/Common/Sexp.hs b/src/SimpleParser/Examples/Common/Sexp.hs --- a/src/SimpleParser/Examples/Common/Sexp.hs +++ b/src/SimpleParser/Examples/Common/Sexp.hs @@ -7,18 +7,20 @@ import Data.Scientific (Scientific) import Data.Sequence (Seq) import Data.Text (Text) +import SimpleParser.Explain (ShowTextBuildable (..), TextBuildable) data Atom = AtomIdent !Text | AtomString !Text | AtomInt !Integer | AtomSci !Scientific - deriving (Eq, Show) + deriving stock (Eq, Show) + deriving (TextBuildable) via (ShowTextBuildable Atom) data SexpF a = SexpAtom !Atom | SexpList !(Seq a) - deriving (Eq, Show, Functor, Foldable, Traversable) + deriving stock (Eq, Show, Functor, Foldable, Traversable) newtype Sexp = Sexp { unSexp :: SexpF Sexp } - deriving (Eq, Show) + deriving stock (Eq, Show) diff --git a/src/SimpleParser/Examples/Lexed/Sexp.hs b/src/SimpleParser/Examples/Lexed/Sexp.hs --- a/src/SimpleParser/Examples/Lexed/Sexp.hs +++ b/src/SimpleParser/Examples/Lexed/Sexp.hs @@ -7,6 +7,11 @@ , Atom (..) , SexpTokLabel (..) , SexpTokParserC + , SexpTokParserM + , sexpTokParser + , SexpParserC + , SexpParserM + , sexpParser , runSexpParser ) where @@ -20,10 +25,10 @@ import Data.Typeable (Typeable) import Data.Void (Void) import SimpleParser (Chunked (..), EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (..), Parser, - PosStream (..), Stream (..), TextLabel, TextualStream, anyToken, applySign, betweenParser, - escapedStringParser, greedyStarParser, lexemeParser, lookAheadMatch, matchToken, numParser, - packChunk, popChunk, popToken, runParserLexed, satisfyToken, signParser, signedNumStartPred, - spaceParser, takeTokensWhile) + PosStream (..), ShowTextBuildable (..), Stream (..), TextBuildable (..), TextLabel, TextualStream, + anyToken, applySign, betweenParser, escapedStringParser, greedyStarParser, lexemeParser, + lookAheadMatch, matchToken, numParser, packChunk, popChunk, popToken, runParserLexed, satisfyToken, + signParser, signedNumStartPred, spaceParser, takeTokensWhile) import SimpleParser.Examples.Common.Sexp (Atom (..), Sexp (..), SexpF (..)) -- First, our tokenizer: @@ -51,6 +56,7 @@ | SexpTokCloseParen | SexpTokAtom !Atom deriving stock (Eq, Show) + deriving (TextBuildable) via (ShowTextBuildable SexpTok) nonDelimPred :: Char -> Bool nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c) @@ -138,11 +144,11 @@ isAtomTok = \case { SexpTokAtom _ -> True; _ -> False } atomP :: SexpParserC s => SexpParserM s Atom -atomP = popToken >>= \case { Just (SexpTokAtom a) -> pure a; _ -> empty } +atomP = popToken >>= \case { Just (SexpTokAtom a) -> pure a; _ -> fail "invalid atom" } openParenP, closeParenP :: SexpParserC s => SexpParserM s () -openParenP = popToken >>= \case { Just SexpTokOpenParen -> pure (); _ -> empty } -closeParenP = popToken >>= \case { Just SexpTokCloseParen -> pure (); _ -> empty } +openParenP = void (matchToken SexpTokOpenParen) +closeParenP = void (matchToken SexpTokCloseParen) listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a) listP root = betweenParser openParenP closeParenP (greedyStarParser root) @@ -164,4 +170,4 @@ Typeable s, Typeable (Token s), Typeable (Chunk s), Typeable (Pos s), Show s, Show (Token s), Show (Chunk s), Show (Pos s), SexpTokParserC s, MonadThrow m) => s -> m Sexp -runSexpParser = runParserLexed sexpTokParser sexpParser +runSexpParser = runParserLexed sexpTokParser id sexpParser diff --git a/src/SimpleParser/Explain.hs b/src/SimpleParser/Explain.hs --- a/src/SimpleParser/Explain.hs +++ b/src/SimpleParser/Explain.hs @@ -2,7 +2,9 @@ {-# LANGUAGE UndecidableInstances #-} module SimpleParser.Explain - ( ExplainLabel (..) + ( TextBuildable (..) + , ShowTextBuildable (..) + , ExplainLabel (..) , ErrorExplanation (..) , ExplainError (..) , Explainable @@ -18,14 +20,45 @@ import qualified Data.Sequence as Seq import Data.Text (Text) import Data.Void (Void, absurd) -import SimpleParser.Chunked (TextualChunked (..)) import SimpleParser.Common (CompoundTextLabel (..), TextLabel (..)) import SimpleParser.Result (CompoundError (..), ParseError (..), RawError (..), StreamError (..), parseErrorEnclosingLabels, parseErrorNarrowestSpan) -import SimpleParser.Stream (HasLinePos (..), PosStream (..), Span (..), Stream (..), TextualStream) +import SimpleParser.Stream (HasLinePos (..), PosStream (..), Span (..), Stream (..)) import Text.Builder (Builder) import qualified Text.Builder as TB +-- | Types that can be rendered into a textual error message +-- (Effectively a fancy Show) +class TextBuildable a where + buildText :: a -> Builder + +instance TextBuildable Char where + buildText = TB.char + +instance TextBuildable String where + buildText = TB.string + +instance TextBuildable Text where + buildText = TB.text + +instance TextBuildable Builder where + buildText = id + +buildTextFromList :: TextBuildable a => [a] -> Builder +buildTextFromList ss = "[" <> TB.intercalate ", " (fmap buildText ss) <> "]" + +instance TextBuildable a => TextBuildable [a] where + buildText = buildTextFromList + +instance TextBuildable a => TextBuildable (Seq a) where + buildText = buildTextFromList . toList + +-- | Deriving-Via wrapper for 'TextBuildable' for types with 'Show' +newtype ShowTextBuildable a = ShowTextBuildable { unShowTextBuildable :: a } + +instance Show a => TextBuildable (ShowTextBuildable a) where + buildText = TB.string . show . unShowTextBuildable + class ExplainLabel l where explainLabel :: l -> Builder @@ -63,25 +96,25 @@ endMsg :: Text endMsg = "end of stream" -tokB :: Char -> Builder -tokB t = "token '" <> TB.char t <> "'" +tokB :: TextBuildable a => a -> Builder +tokB t = "token '" <> buildText t <> "'" -tokT :: Char -> Text +tokT :: TextBuildable a => a -> Text tokT = TB.run . tokB -mayTokT :: Maybe Char -> Text +mayTokT :: TextBuildable a => Maybe a -> Text mayTokT = maybe endMsg tokT -chunkB :: TextualChunked chunk => chunk -> Builder -chunkB k = "chunk \"" <> buildChunk k <> "\"" +chunkB :: TextBuildable a => a -> Builder +chunkB k = "chunk \"" <> buildText k <> "\"" -chunkT :: TextualChunked chunk => chunk -> Text +chunkT :: TextBuildable a => a -> Text chunkT = TB.run . chunkB -mayChunkT :: TextualChunked chunk => Maybe chunk -> Text +mayChunkT :: TextBuildable a => Maybe a -> Text mayChunkT = maybe endMsg chunkT -instance (Token s ~ Char, TextualChunked (Chunk s)) => ExplainError (StreamError s) where +instance (TextBuildable (Token s), TextBuildable (Chunk s)) => ExplainError (StreamError s) where explainError (StreamError re) = case re of RawErrorMatchEnd actTok -> @@ -101,14 +134,14 @@ RawErrorDropTokensWhile1 mayActTok -> ErrorExplanation "failed to drop 1 or more tokens" Nothing (Just (mayTokT mayActTok)) -instance (Token s ~ Char, TextualChunked (Chunk s), ExplainError e) => ExplainError (CompoundError s e) where +instance (TextBuildable (Token s), TextBuildable (Chunk s), ExplainError e) => ExplainError (CompoundError s e) where explainError ce = case ce of CompoundErrorStream se -> explainError se CompoundErrorFail msg -> ErrorExplanation msg Nothing Nothing CompoundErrorCustom e -> explainError e -type Explainable l s e = (TextualStream s, PosStream s, ExplainLabel l, ExplainError e) +type Explainable l s e = (PosStream s, ExplainLabel l, ExplainError e) data ParseErrorExplanation p = ParseErrorExplanation { peeSpan :: !(Span p) @@ -117,7 +150,7 @@ , peeErrExp :: !ErrorExplanation } deriving (Eq, Show) -explainParseError :: Explainable l s e => ParseError l s e -> ParseErrorExplanation (Pos s) +explainParseError :: (TextBuildable (Token s), TextBuildable (Chunk s), Explainable l s e) => ParseError l s e -> ParseErrorExplanation (Pos s) explainParseError pe = let (mayLab, sp) = parseErrorNarrowestSpan pe context = fmap explainLabelText (parseErrorEnclosingLabels pe) diff --git a/src/SimpleParser/Interactive.hs b/src/SimpleParser/Interactive.hs --- a/src/SimpleParser/Interactive.hs +++ b/src/SimpleParser/Interactive.hs @@ -2,6 +2,7 @@ module SimpleParser.Interactive ( ErrorStyle (..) + , renderInteractive , parseInteractiveStyle , parseInteractive ) where @@ -13,7 +14,7 @@ import qualified Data.Text.Lazy.IO as TLIO import Errata (Errata (..), prettyErrors) import Errata.Styles (fancyPointer, fancyStyle) -import SimpleParser.Errata (errataParseError) +import SimpleParser.Errata (LinePosExplainable, errataParseError) import SimpleParser.Explain (Explainable, buildAllParseErrorExplanations, explainParseError) import SimpleParser.Input (matchEnd) import SimpleParser.Parser (Parser, runParser) @@ -26,23 +27,29 @@ | ErrorStyleExplain deriving stock (Eq, Show) -parseInteractiveStyle :: (s ~ LinePosStream Text, Explainable l s e, Show a) => ErrorStyle -> Parser l s e a -> String -> IO () -parseInteractiveStyle errStyle parser input = - case runParser (parser <* matchEnd) (newLinePosStream (T.pack input)) of - Nothing -> - putStrLn "No result." - Just (ParseResultError (ParseErrorBundle es)) -> - case errStyle of - ErrorStyleErrata -> - let blocks = fmap (errataParseError fancyStyle fancyPointer "") (toList es) - errata = Errata Nothing blocks Nothing - pretty = prettyErrors input [errata] - in TLIO.putStrLn pretty - ErrorStyleExplain -> - let b = buildAllParseErrorExplanations (fmap explainParseError (toList es)) - in TIO.putStrLn (TB.run ("Errors:\n" <> b)) - Just (ParseResultSuccess (ParseSuccess _ a)) -> - putStrLn "Success:" *> print a +renderInteractive :: (LinePosExplainable l s e) => ErrorStyle -> String -> Maybe (ParseResult l s e a) -> IO () +renderInteractive errStyle input = \case + Nothing -> + putStrLn "No result" + Just (ParseResultError (ParseErrorBundle es)) -> + case errStyle of + ErrorStyleErrata -> + let blocks = fmap (errataParseError fancyStyle fancyPointer "") (toList es) + errata = Errata Nothing blocks Nothing + pretty = prettyErrors input [errata] + in TLIO.putStrLn pretty + ErrorStyleExplain -> + let b = buildAllParseErrorExplanations (fmap explainParseError (toList es)) + in TIO.putStrLn (TB.run ("Errors:\n" <> b)) + Just (ParseResultSuccess _) -> + putStrLn "Success" -parseInteractive :: (s ~ LinePosStream Text, Explainable l s e, Show a) => Parser l s e a -> String -> IO () +parseInteractiveStyle :: (s ~ LinePosStream Text, Explainable l s e) => ErrorStyle -> Parser l s e a -> String -> IO (Maybe a) +parseInteractiveStyle errStyle parser input = do + let mres = runParser (parser <* matchEnd) (newLinePosStream (T.pack input)) + renderInteractive errStyle input mres + let res = case mres of { Just (ParseResultSuccess (ParseSuccess _ a)) -> Just a; _ -> Nothing } + pure res + +parseInteractive :: (s ~ LinePosStream Text, Explainable l s e) => Parser l s e a -> String -> IO (Maybe a) parseInteractive = parseInteractiveStyle ErrorStyleErrata diff --git a/src/SimpleParser/Lexer.hs b/src/SimpleParser/Lexer.hs --- a/src/SimpleParser/Lexer.hs +++ b/src/SimpleParser/Lexer.hs @@ -6,15 +6,22 @@ , spannedParser , lexedParser , runParserLexed + , lexedParseInteractive ) where import Control.Monad.Catch (MonadThrow) import Control.Monad.State.Strict (gets) import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as T import Data.Typeable (Typeable) -import SimpleParser.Parser (Parser, ParserT, greedyStarParser) -import SimpleParser.Stream (PosStream (..), Span (Span), Stream (..)) +import SimpleParser.Explain (ExplainError, ExplainLabel, TextBuildable) +import SimpleParser.Input (matchEnd) +import SimpleParser.Interactive (ErrorStyle (..), renderInteractive) +import SimpleParser.Parser (Parser, ParserT, greedyStarParser, runParser) +import SimpleParser.Result (ParseResult (..), ParseSuccess (..)) +import SimpleParser.Stream (HasLinePos (..), LinePosStream, PosStream (..), Span (..), Stream (..), newLinePosStream) import SimpleParser.Throw (runParserEnd) -- | A value annotated with a 'Span' @@ -24,45 +31,58 @@ } deriving stock (Eq, Show, Functor, Foldable, Traversable) -- | A materialized sequence of 'Spanned' values -newtype LexedStream p a = LexedStream { unLexedStream :: Seq (Spanned p a) } - deriving stock (Show, Functor, Foldable, Traversable) +data LexedStream p a = LexedStream + { lsTokens :: !(Seq (Spanned p a)) + , lsEndPos :: !p + } deriving stock (Eq, Show, Functor, Foldable, Traversable) + +newtype LexedChunk a = LexedChunk { unLexedChunk :: Seq a } + deriving stock (Show) deriving newtype (Eq) instance Stream (LexedStream p a) where type Token (LexedStream p a) = a type Chunk (LexedStream p a) = Seq a - streamTake1 (LexedStream ss) = + streamTake1 (LexedStream ss ep) = case ss of Empty -> Nothing - Spanned _ a :<| tl -> Just (a, LexedStream tl) + Spanned _ a :<| tl -> Just (a, LexedStream tl ep) - streamTakeN n s@(LexedStream ss) + streamTakeN n s@(LexedStream ss ep) | n <= 0 = Just (Seq.empty, s) | Seq.null ss = Nothing | otherwise = let (out, rest) = Seq.splitAt n ss - in Just (fmap spannedValue out, LexedStream rest) + in Just (fmap spannedValue out, LexedStream rest ep) - streamTakeWhile f (LexedStream ss) = + streamTakeWhile f (LexedStream ss ep) = let (out, rest) = Seq.spanl (f . spannedValue) ss - in (fmap spannedValue out, LexedStream rest) + in (fmap spannedValue out, LexedStream rest ep) -- TODO(ejconlon) Specialize drops -- | Position in a 'LexedStream' data LexedSpan p = - LexedSpanNext !(Span p) - | LexedSpanEnd + LexedSpanElem !(Span p) + | LexedSpanEnd !p deriving stock (Eq, Show) +instance HasLinePos p => HasLinePos (LexedSpan p) where + viewLine = \case + LexedSpanElem sp -> viewLine (spanStart sp) + LexedSpanEnd p -> viewLine p + viewCol = \case + LexedSpanElem sp -> viewCol (spanStart sp) + LexedSpanEnd p -> viewCol p + instance PosStream (LexedStream p a) where type Pos (LexedStream p a) = LexedSpan p - streamViewPos (LexedStream ss) = + streamViewPos (LexedStream ss ep) = case ss of - Empty -> LexedSpanEnd - Spanned sp _ :<| _ -> LexedSpanNext sp + Empty -> LexedSpanEnd ep + Spanned sp _ :<| _ -> LexedSpanElem sp -- | Annotates parse result with a span spannedParser :: (PosStream s, Monad m) => ParserT l s e m a -> ParserT l s e m (Spanned (Pos s) a) @@ -74,15 +94,35 @@ -- | Given a parser for a single token, repeatedly apply it and annotate results with spans lexedParser :: (PosStream s, Monad m) => ParserT l s e m a -> ParserT l s e m (LexedStream (Pos s) a) -lexedParser p = fmap LexedStream (greedyStarParser (spannedParser p)) +lexedParser p = LexedStream <$> greedyStarParser (spannedParser p) <*> gets streamViewPos --- | Similar to 'runParserEnd' - first lexes the entire stream then runs the second parser over the results +-- | Similar to 'runParserEnd' - first lexes the entire stream, applies the given cleanup function, +-- then runs the second parser over the results runParserLexed :: ( Typeable l1, Typeable e1, Typeable s, Typeable (Token s), Typeable (Chunk s), Show l1, Show e1, Show s, Show (Token s), Show (Chunk s), Typeable l2, Typeable e2, Typeable (Pos s), Typeable a, Show l2, Show e2, Show (Pos s), Show a, - PosStream s, MonadThrow m) => Parser l1 s e1 a -> Parser l2 (LexedStream (Pos s) a) e2 b -> s -> m b -runParserLexed lp p s = do + PosStream s, MonadThrow m) => Parser l1 s e1 a -> (LexedStream (Pos s) a -> LexedStream (Pos s) a) -> Parser l2 (LexedStream (Pos s) a) e2 b -> s -> m b +runParserLexed lp f p s = do ls <- runParserEnd (lexedParser lp) s - runParserEnd p ls + runParserEnd p (f ls) + +-- | Similar to 'parseInteractive' +lexedParseInteractive :: ( + s ~ LinePosStream Text, TextBuildable a, + ExplainLabel l1, ExplainError e1, ExplainLabel l2, ExplainError e2) => + Parser l1 s e1 a -> (LexedStream (Pos s) a -> LexedStream (Pos s) a) -> Parser l2 (LexedStream (Pos s) a) e2 b -> String -> IO (Maybe b) +lexedParseInteractive lp f p input = do + -- TODO renderInteractive TWICE + let lexRes = runParser (lexedParser lp <* matchEnd) (newLinePosStream (T.pack input)) + putStrLn "Lex result:" + renderInteractive ErrorStyleErrata input lexRes + case lexRes of + Just (ParseResultSuccess (ParseSuccess _ ls)) -> do + let parseRes = runParser (p <* matchEnd) (f ls) + putStrLn "Parse result:" + renderInteractive ErrorStyleErrata input parseRes + let res = case parseRes of { Just (ParseResultSuccess (ParseSuccess _ b)) -> Just b; _ -> Nothing } + pure res + _ -> pure Nothing