{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} module SimpleParser.Explain 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 (LinePos (..), 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 -> Builder eeReason :: !Builder , ErrorExplanation -> Maybe Builder eeExpected :: !(Maybe Builder) , ErrorExplanation -> Maybe Builder eeActual :: !(Maybe Builder) } class ExplainError e where explainError :: e -> ErrorExplanation instance ExplainError Void where explainError :: Void -> ErrorExplanation explainError = Void -> ErrorExplanation forall a. Void -> a absurd endMsg :: Builder endMsg :: Builder endMsg = Builder "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 "'" mayTokB :: Maybe Char -> Builder mayTokB :: Maybe Char -> Builder mayTokB = Builder -> (Char -> Builder) -> Maybe Char -> Builder forall b a. b -> (a -> b) -> Maybe a -> b maybe Builder endMsg Char -> Builder tokB 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 "\"" mayChunkB :: TextualChunked chunk => Maybe chunk -> Builder mayChunkB :: Maybe chunk -> Builder mayChunkB = Builder -> (chunk -> Builder) -> Maybe chunk -> Builder forall b a. b -> (a -> b) -> Maybe a -> b maybe Builder endMsg chunk -> Builder forall chunk. TextualChunked chunk => chunk -> Builder chunkB 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 -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to match end of stream" (Builder -> Maybe Builder forall a. a -> Maybe a Just Builder endMsg) (Builder -> Maybe Builder forall a. a -> Maybe a Just (Char -> Builder tokB Char Token s actTok)) RawError (Chunk s) (Token s) RawErrorAnyToken -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to match any token" (Builder -> Maybe Builder forall a. a -> Maybe a Just Builder "any token") (Builder -> Maybe Builder forall a. a -> Maybe a Just Builder endMsg) RawError (Chunk s) (Token s) RawErrorAnyChunk -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to match any chunk" (Builder -> Maybe Builder forall a. a -> Maybe a Just Builder "any chunk") (Builder -> Maybe Builder forall a. a -> Maybe a Just Builder endMsg) RawErrorSatisfyToken Maybe (Token s) mayActTok -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to satisfy token predicate" Maybe Builder forall a. Maybe a Nothing (Builder -> Maybe Builder forall a. a -> Maybe a Just (Maybe Char -> Builder mayTokB Maybe Char Maybe (Token s) mayActTok)) RawErrorMatchToken Token s expTok Maybe (Token s) mayActTok -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to match token" (Builder -> Maybe Builder forall a. a -> Maybe a Just (Char -> Builder tokB Char Token s expTok)) (Builder -> Maybe Builder forall a. a -> Maybe a Just (Maybe Char -> Builder mayTokB Maybe Char Maybe (Token s) mayActTok)) RawErrorMatchChunk Chunk s expChunk Maybe (Chunk s) mayActChunk -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to match chunk" (Builder -> Maybe Builder forall a. a -> Maybe a Just (Chunk s -> Builder forall chunk. TextualChunked chunk => chunk -> Builder chunkB Chunk s expChunk)) (Builder -> Maybe Builder forall a. a -> Maybe a Just (Maybe (Chunk s) -> Builder forall chunk. TextualChunked chunk => Maybe chunk -> Builder mayChunkB Maybe (Chunk s) mayActChunk)) RawErrorTakeTokensWhile1 Maybe (Token s) mayActTok -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to take 1 or more tokens" Maybe Builder forall a. Maybe a Nothing (Builder -> Maybe Builder forall a. a -> Maybe a Just (Maybe Char -> Builder mayTokB Maybe Char Maybe (Token s) mayActTok)) RawErrorDropTokensWhile1 Maybe (Token s) mayActTok -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation Builder "failed to drop 1 or more tokens" Maybe Builder forall a. Maybe a Nothing (Builder -> Maybe Builder forall a. a -> Maybe a Just (Maybe Char -> Builder mayTokB 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 -> Builder -> Maybe Builder -> Maybe Builder -> ErrorExplanation ErrorExplanation (Text -> Builder TB.text Text msg) Maybe Builder forall a. Maybe a Nothing Maybe Builder 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, ExplainLabel l, ExplainError e) data ParseErrorExplanation p = ParseErrorExplanation { ParseErrorExplanation p -> Span p peeSpan :: !(Span p) , ParseErrorExplanation p -> Seq Builder peeContext :: !(Seq Builder) , ParseErrorExplanation p -> Maybe Builder peeDetails :: !(Maybe Builder) , ParseErrorExplanation p -> ErrorExplanation peeErrExp :: !ErrorExplanation } 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. Stream s => ParseError l s e -> (Maybe l, Span (Pos s)) parseErrorNarrowestSpan ParseError l s e pe context :: Seq Builder context = (l -> Builder) -> Seq l -> Seq Builder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap l -> Builder forall l. ExplainLabel l => l -> Builder explainLabel (ParseError l s e -> Seq l forall l s e. ParseError l s e -> Seq l parseErrorEnclosingLabels ParseError l s e pe) mayDetails :: Maybe Builder mayDetails = (l -> Builder) -> Maybe l -> Maybe Builder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap l -> Builder forall l. ExplainLabel l => l -> Builder explainLabel 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 Builder -> Maybe Builder -> ErrorExplanation -> ParseErrorExplanation (Pos s) forall p. Span p -> Seq Builder -> Maybe Builder -> ErrorExplanation -> ParseErrorExplanation p ParseErrorExplanation Span (Pos s) sp Seq Builder context Maybe Builder mayDetails ErrorExplanation errExp buildSpan :: Span LinePos -> Builder buildSpan :: Span LinePos -> Builder buildSpan (Span (LinePos Offset _ Line sl Col sc) (LinePos Offset _ Line el Col ec)) = Line -> Builder forall a. Integral a => a -> Builder TB.decimal (Line -> Line forall a. Enum a => a -> a succ Line sl) 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 sc) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder "-" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Line -> Builder forall a. Integral a => a -> Builder TB.decimal (Line -> Line forall a. Enum a => a -> a succ Line el) 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 ec) buildErrorExplanation :: Maybe Builder -> ErrorExplanation -> [Builder] buildErrorExplanation :: Maybe Builder -> ErrorExplanation -> [Builder] buildErrorExplanation Maybe Builder mayDetails (ErrorExplanation Builder reason Maybe Builder mayExpected Maybe Builder 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 <> Builder 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] -> (Builder -> [Builder]) -> Maybe Builder -> [Builder] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (\Builder ex -> [Builder "[Expected] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder ex]) Maybe Builder mayExpected , [Builder] -> (Builder -> [Builder]) -> Maybe Builder -> [Builder] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (\Builder ac -> [Builder "[Actual ] " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder ac]) Maybe Builder mayActual ] buildParseErrorExplanation :: ParseErrorExplanation LinePos -> Builder buildParseErrorExplanation :: ParseErrorExplanation LinePos -> Builder buildParseErrorExplanation (ParseErrorExplanation Span LinePos sp Seq Builder context Maybe Builder 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 LinePos -> Builder buildSpan Span LinePos sp] , [Builder "[Context ] || " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder -> Seq Builder -> Builder forall (foldable :: * -> *). Foldable foldable => Builder -> foldable Builder -> Builder TB.intercalate Builder " |> " Seq Builder context | Bool -> Bool not (Seq Builder -> Bool forall a. Seq a -> Bool Seq.null Seq Builder context)] ] tl :: [Builder] tl = Maybe Builder -> ErrorExplanation -> [Builder] buildErrorExplanation Maybe Builder 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 :: Foldable f => f (ParseErrorExplanation LinePos) -> Builder buildAllParseErrorExplanations :: f (ParseErrorExplanation LinePos) -> Builder buildAllParseErrorExplanations = Builder -> [Builder] -> Builder forall (foldable :: * -> *). Foldable foldable => Builder -> foldable Builder -> Builder TB.intercalate Builder "\n\n" ([Builder] -> Builder) -> (f (ParseErrorExplanation LinePos) -> [Builder]) -> f (ParseErrorExplanation LinePos) -> Builder forall b c a. (b -> c) -> (a -> b) -> a -> c . (ParseErrorExplanation LinePos -> Builder) -> [ParseErrorExplanation LinePos] -> [Builder] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ParseErrorExplanation LinePos -> Builder buildParseErrorExplanation ([ParseErrorExplanation LinePos] -> [Builder]) -> (f (ParseErrorExplanation LinePos) -> [ParseErrorExplanation LinePos]) -> f (ParseErrorExplanation LinePos) -> [Builder] forall b c a. (b -> c) -> (a -> b) -> a -> c . f (ParseErrorExplanation LinePos) -> [ParseErrorExplanation LinePos] forall (t :: * -> *) a. Foldable t => t a -> [a] toList