{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} module SimpleParser.Explain ( ExplainLabel (..) , ErrorExplanation (..) , ExplainError (..) , Explainable , ParseErrorExplanation (..) , explainParseError , buildParseErrorExplanation , buildAllParseErrorExplanations ) where import Control.Monad (join) import Data.Foldable (toList) import Data.Sequence (Seq) 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 Text.Builder (Builder) import qualified Text.Builder as TB class ExplainLabel l where explainLabel :: l -> Builder explainLabelText :: l -> Text explainLabelText = Builder -> Text TB.run (Builder -> Text) -> (l -> Builder) -> l -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . l -> Builder forall l. ExplainLabel l => l -> Builder explainLabel instance ExplainLabel Void where explainLabel :: Void -> Builder explainLabel = Void -> Builder forall a. Void -> a absurd instance ExplainLabel TextLabel where explainLabel :: TextLabel -> Builder explainLabel TextLabel l = case TextLabel l of TextLabel TextLabelSpace -> Builder "space" TextLabel TextLabelHSpace -> Builder "non-line-breaking space" TextLabel TextLabelDigit -> Builder "digit" instance ExplainLabel l => ExplainLabel (CompoundTextLabel l) where explainLabel :: CompoundTextLabel l -> Builder explainLabel CompoundTextLabel l c = case CompoundTextLabel l c of CompoundTextLabelText TextLabel l -> TextLabel -> Builder forall l. ExplainLabel l => l -> Builder explainLabel TextLabel l CompoundTextLabelCustom l l -> l -> Builder forall l. ExplainLabel l => l -> Builder explainLabel l l data ErrorExplanation = ErrorExplanation { ErrorExplanation -> Text eeReason :: !Text , ErrorExplanation -> Maybe Text eeExpected :: !(Maybe Text) , ErrorExplanation -> Maybe Text eeActual :: !(Maybe Text) } deriving (ErrorExplanation -> ErrorExplanation -> Bool (ErrorExplanation -> ErrorExplanation -> Bool) -> (ErrorExplanation -> ErrorExplanation -> Bool) -> Eq ErrorExplanation forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: ErrorExplanation -> ErrorExplanation -> Bool $c/= :: ErrorExplanation -> ErrorExplanation -> Bool == :: ErrorExplanation -> ErrorExplanation -> Bool $c== :: ErrorExplanation -> ErrorExplanation -> Bool Eq, Int -> ErrorExplanation -> ShowS [ErrorExplanation] -> ShowS ErrorExplanation -> String (Int -> ErrorExplanation -> ShowS) -> (ErrorExplanation -> String) -> ([ErrorExplanation] -> ShowS) -> Show ErrorExplanation forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ErrorExplanation] -> ShowS $cshowList :: [ErrorExplanation] -> ShowS show :: ErrorExplanation -> String $cshow :: ErrorExplanation -> String showsPrec :: Int -> ErrorExplanation -> ShowS $cshowsPrec :: Int -> ErrorExplanation -> ShowS Show) class ExplainError e where explainError :: e -> ErrorExplanation instance ExplainError Void where explainError :: Void -> ErrorExplanation explainError = Void -> ErrorExplanation forall a. Void -> a absurd endMsg :: Text endMsg :: Text endMsg = Text "end of stream" tokB :: Char -> Builder tokB :: Char -> Builder tokB Char t = Builder "token '" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Char -> Builder TB.char Char t Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder "'" tokT :: Char -> Text tokT :: Char -> Text tokT = Builder -> Text TB.run (Builder -> Text) -> (Char -> Builder) -> Char -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> Builder tokB mayTokT :: Maybe Char -> Text mayTokT :: Maybe Char -> Text mayTokT = Text -> (Char -> Text) -> Maybe Char -> Text forall b a. b -> (a -> b) -> Maybe a -> b maybe Text endMsg Char -> Text tokT chunkB :: TextualChunked chunk => chunk -> Builder chunkB :: chunk -> Builder chunkB chunk k = Builder "chunk \"" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> chunk -> Builder forall chunk. TextualChunked chunk => chunk -> Builder buildChunk chunk k Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder "\"" chunkT :: TextualChunked chunk => chunk -> Text chunkT :: chunk -> Text chunkT = Builder -> Text TB.run (Builder -> Text) -> (chunk -> Builder) -> chunk -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . chunk -> Builder forall chunk. TextualChunked chunk => chunk -> Builder chunkB mayChunkT :: TextualChunked chunk => Maybe chunk -> Text mayChunkT :: Maybe chunk -> Text mayChunkT = Text -> (chunk -> Text) -> Maybe chunk -> Text forall b a. b -> (a -> b) -> Maybe a -> b maybe Text endMsg chunk -> Text forall chunk. TextualChunked chunk => chunk -> Text chunkT instance (Token s ~ Char, TextualChunked (Chunk s)) => ExplainError (StreamError s) where explainError :: StreamError s -> ErrorExplanation explainError (StreamError RawError (Chunk s) (Token s) re) = case RawError (Chunk s) (Token s) re of RawErrorMatchEnd Token s actTok -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to match end of stream" (Text -> Maybe Text forall a. a -> Maybe a Just Text endMsg) (Text -> Maybe Text forall a. a -> Maybe a Just (Char -> Text tokT Char Token s actTok)) RawError (Chunk s) (Token s) RawErrorAnyToken -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to match any token" (Text -> Maybe Text forall a. a -> Maybe a Just Text "any token") (Text -> Maybe Text forall a. a -> Maybe a Just Text endMsg) RawError (Chunk s) (Token s) RawErrorAnyChunk -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to match any chunk" (Text -> Maybe Text forall a. a -> Maybe a Just Text "any chunk") (Text -> Maybe Text forall a. a -> Maybe a Just Text endMsg) RawErrorSatisfyToken Maybe (Token s) mayActTok -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to satisfy token predicate" Maybe Text forall a. Maybe a Nothing (Text -> Maybe Text forall a. a -> Maybe a Just (Maybe Char -> Text mayTokT Maybe Char Maybe (Token s) mayActTok)) RawErrorMatchToken Token s expTok Maybe (Token s) mayActTok -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to match token" (Text -> Maybe Text forall a. a -> Maybe a Just (Char -> Text tokT Char Token s expTok)) (Text -> Maybe Text forall a. a -> Maybe a Just (Maybe Char -> Text mayTokT Maybe Char Maybe (Token s) mayActTok)) RawErrorMatchChunk Chunk s expChunk Maybe (Chunk s) mayActChunk -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to match chunk" (Text -> Maybe Text forall a. a -> Maybe a Just (Chunk s -> Text forall chunk. TextualChunked chunk => chunk -> Text chunkT Chunk s expChunk)) (Text -> Maybe Text forall a. a -> Maybe a Just (Maybe (Chunk s) -> Text forall chunk. TextualChunked chunk => Maybe chunk -> Text mayChunkT Maybe (Chunk s) mayActChunk)) RawErrorTakeTokensWhile1 Maybe (Token s) mayActTok -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to take 1 or more tokens" Maybe Text forall a. Maybe a Nothing (Text -> Maybe Text forall a. a -> Maybe a Just (Maybe Char -> Text mayTokT Maybe Char Maybe (Token s) mayActTok)) RawErrorDropTokensWhile1 Maybe (Token s) mayActTok -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text "failed to drop 1 or more tokens" Maybe Text forall a. Maybe a Nothing (Text -> Maybe Text forall a. a -> Maybe a Just (Maybe Char -> Text mayTokT Maybe Char Maybe (Token s) mayActTok)) instance (Token s ~ Char, TextualChunked (Chunk s), ExplainError e) => ExplainError (CompoundError s e) where explainError :: CompoundError s e -> ErrorExplanation explainError CompoundError s e ce = case CompoundError s e ce of CompoundErrorStream StreamError s se -> StreamError s -> ErrorExplanation forall e. ExplainError e => e -> ErrorExplanation explainError StreamError s se CompoundErrorFail Text msg -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation ErrorExplanation Text msg Maybe Text forall a. Maybe a Nothing Maybe Text forall a. Maybe a Nothing CompoundErrorCustom e e -> e -> ErrorExplanation forall e. ExplainError e => e -> ErrorExplanation explainError e e type Explainable l s e = (TextualStream s, PosStream s, ExplainLabel l, ExplainError e) data ParseErrorExplanation p = ParseErrorExplanation { ParseErrorExplanation p -> Span p peeSpan :: !(Span p) , ParseErrorExplanation p -> Seq Text peeContext :: !(Seq Text) , ParseErrorExplanation p -> Maybe Text peeDetails :: !(Maybe Text) , ParseErrorExplanation p -> ErrorExplanation peeErrExp :: !ErrorExplanation } deriving (ParseErrorExplanation p -> ParseErrorExplanation p -> Bool (ParseErrorExplanation p -> ParseErrorExplanation p -> Bool) -> (ParseErrorExplanation p -> ParseErrorExplanation p -> Bool) -> Eq (ParseErrorExplanation p) forall p. Eq p => ParseErrorExplanation p -> ParseErrorExplanation p -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: ParseErrorExplanation p -> ParseErrorExplanation p -> Bool $c/= :: forall p. Eq p => ParseErrorExplanation p -> ParseErrorExplanation p -> Bool == :: ParseErrorExplanation p -> ParseErrorExplanation p -> Bool $c== :: forall p. Eq p => ParseErrorExplanation p -> ParseErrorExplanation p -> Bool Eq, Int -> ParseErrorExplanation p -> ShowS [ParseErrorExplanation p] -> ShowS ParseErrorExplanation p -> String (Int -> ParseErrorExplanation p -> ShowS) -> (ParseErrorExplanation p -> String) -> ([ParseErrorExplanation p] -> ShowS) -> Show (ParseErrorExplanation p) forall p. Show p => Int -> ParseErrorExplanation p -> ShowS forall p. Show p => [ParseErrorExplanation p] -> ShowS forall p. Show p => ParseErrorExplanation p -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ParseErrorExplanation p] -> ShowS $cshowList :: forall p. Show p => [ParseErrorExplanation p] -> ShowS show :: ParseErrorExplanation p -> String $cshow :: forall p. Show p => ParseErrorExplanation p -> String showsPrec :: Int -> ParseErrorExplanation p -> ShowS $cshowsPrec :: forall p. Show p => Int -> ParseErrorExplanation p -> ShowS Show) explainParseError :: Explainable l s e => ParseError l s e -> ParseErrorExplanation (Pos s) explainParseError :: ParseError l s e -> ParseErrorExplanation (Pos s) explainParseError ParseError l s e pe = let (Maybe l mayLab, Span (Pos s) sp) = ParseError l s e -> (Maybe l, Span (Pos s)) forall s l e. PosStream s => ParseError l s e -> (Maybe l, Span (Pos s)) parseErrorNarrowestSpan ParseError l s e pe context :: Seq Text context = (l -> Text) -> Seq l -> Seq Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap l -> Text forall l. ExplainLabel l => l -> Text explainLabelText (ParseError l s e -> Seq l forall l s e. ParseError l s e -> Seq l parseErrorEnclosingLabels ParseError l s e pe) mayDetails :: Maybe Text mayDetails = (l -> Text) -> Maybe l -> Maybe Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap l -> Text forall l. ExplainLabel l => l -> Text explainLabelText Maybe l mayLab errExp :: ErrorExplanation errExp = CompoundError s e -> ErrorExplanation forall e. ExplainError e => e -> ErrorExplanation explainError (ParseError l s e -> CompoundError s e forall l s e. ParseError l s e -> CompoundError s e peError ParseError l s e pe) in Span (Pos s) -> Seq Text -> Maybe Text -> ErrorExplanation -> ParseErrorExplanation (Pos s) forall p. Span p -> Seq Text -> Maybe Text -> ErrorExplanation -> ParseErrorExplanation p ParseErrorExplanation Span (Pos s) sp Seq Text context Maybe Text mayDetails ErrorExplanation errExp buildSpan :: HasLinePos p => Span p -> Builder buildSpan :: Span p -> Builder buildSpan (Span p p1 p p2) = let l1 :: Line l1 = p -> Line forall p. HasLinePos p => p -> Line viewLine p p1 c1 :: Col c1 = p -> Col forall p. HasLinePos p => p -> Col viewCol p p1 l2 :: Line l2 = p -> Line forall p. HasLinePos p => p -> Line viewLine p p2 c2 :: Col c2 = p -> Col forall p. HasLinePos p => p -> Col viewCol p p2 r1 :: Builder r1 = Line -> Builder forall a. Integral a => a -> Builder TB.decimal (Line -> Line forall a. Enum a => a -> a succ Line l1) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder ":" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Col -> Builder forall a. Integral a => a -> Builder TB.decimal (Col -> Col forall a. Enum a => a -> a succ Col c1) r2 :: Builder r2 = Line -> Builder forall a. Integral a => a -> Builder TB.decimal (Line -> Line forall a. Enum a => a -> a succ Line l2) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder ":" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Col -> Builder forall a. Integral a => a -> Builder TB.decimal (Col -> Col forall a. Enum a => a -> a succ Col c2) in if Line l1 Line -> Line -> Bool forall a. Eq a => a -> a -> Bool == Line l2 Bool -> Bool -> Bool && Col c1 Col -> Col -> Bool forall a. Eq a => a -> a -> Bool == Col c2 then Builder r1 else Builder r1 Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder "-" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder r2 buildErrorExplanation :: Maybe Builder -> ErrorExplanation -> [Builder] buildErrorExplanation :: Maybe Builder -> ErrorExplanation -> [Builder] buildErrorExplanation Maybe Builder mayDetails (ErrorExplanation Text reason Maybe Text mayExpected Maybe Text mayActual) = [[Builder]] -> [Builder] forall (m :: * -> *) a. Monad m => m (m a) -> m a join [ [Builder "[Reason ] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder TB.text Text reason] , [Builder] -> (Builder -> [Builder]) -> Maybe Builder -> [Builder] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (\Builder de -> [Builder "[Details ] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder de]) Maybe Builder mayDetails , [Builder] -> (Text -> [Builder]) -> Maybe Text -> [Builder] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (\Text ex -> [Builder "[Expected] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder TB.text Text ex]) Maybe Text mayExpected , [Builder] -> (Text -> [Builder]) -> Maybe Text -> [Builder] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (\Text ac -> [Builder "[Actual ] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder TB.text Text ac]) Maybe Text mayActual ] buildParseErrorExplanation :: HasLinePos p => ParseErrorExplanation p -> Builder buildParseErrorExplanation :: ParseErrorExplanation p -> Builder buildParseErrorExplanation (ParseErrorExplanation Span p sp Seq Text context Maybe Text mayDetails ErrorExplanation errExp) = let hd :: [Builder] hd = [[Builder]] -> [Builder] forall (m :: * -> *) a. Monad m => m (m a) -> m a join [ [Builder "[Pos ] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Span p -> Builder forall p. HasLinePos p => Span p -> Builder buildSpan Span p sp] , [Builder "[Context ] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder -> [Builder] -> Builder forall (foldable :: * -> *). Foldable foldable => Builder -> foldable Builder -> Builder TB.intercalate Builder " > " ((Text -> Builder) -> [Text] -> [Builder] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Text -> Builder TB.text (Seq Text -> [Text] forall (t :: * -> *) a. Foldable t => t a -> [a] toList Seq Text context)) | Bool -> Bool not (Seq Text -> Bool forall a. Seq a -> Bool Seq.null Seq Text context)] ] tl :: [Builder] tl = Maybe Builder -> ErrorExplanation -> [Builder] buildErrorExplanation ((Text -> Builder) -> Maybe Text -> Maybe Builder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Text -> Builder TB.text Maybe Text mayDetails) ErrorExplanation errExp in Builder -> [Builder] -> Builder forall (foldable :: * -> *). Foldable foldable => Builder -> foldable Builder -> Builder TB.intercalate Builder "\n" ([Builder] hd [Builder] -> [Builder] -> [Builder] forall a. [a] -> [a] -> [a] ++ [Builder] tl) buildAllParseErrorExplanations :: (HasLinePos p, Foldable f) => f (ParseErrorExplanation p) -> Builder buildAllParseErrorExplanations :: f (ParseErrorExplanation p) -> Builder buildAllParseErrorExplanations = Builder -> [Builder] -> Builder forall (foldable :: * -> *). Foldable foldable => Builder -> foldable Builder -> Builder TB.intercalate Builder "\n\n" ([Builder] -> Builder) -> (f (ParseErrorExplanation p) -> [Builder]) -> f (ParseErrorExplanation p) -> Builder forall b c a. (b -> c) -> (a -> b) -> a -> c . (ParseErrorExplanation p -> Builder) -> [ParseErrorExplanation p] -> [Builder] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ParseErrorExplanation p -> Builder forall p. HasLinePos p => ParseErrorExplanation p -> Builder buildParseErrorExplanation ([ParseErrorExplanation p] -> [Builder]) -> (f (ParseErrorExplanation p) -> [ParseErrorExplanation p]) -> f (ParseErrorExplanation p) -> [Builder] forall b c a. (b -> c) -> (a -> b) -> a -> c . f (ParseErrorExplanation p) -> [ParseErrorExplanation p] forall (t :: * -> *) a. Foldable t => t a -> [a] toList