{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module SimpleParser.Explain
( TextBuildable (..)
, ShowTextBuildable (..)
, 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.Common (CompoundTextLabel (..), TextLabel (..))
import SimpleParser.Result (CompoundError (..), ParseError (..), RawError (..), StreamError (..),
parseErrorEnclosingLabels, parseErrorNarrowestSpan)
import SimpleParser.Stream (HasLinePos (..), PosStream (..), Span (..), Stream (..))
import Text.Builder (Builder)
import qualified Text.Builder as TB
class TextBuildable a where
buildText :: a -> Builder
instance TextBuildable Char where
buildText :: Char -> Builder
buildText = Char -> Builder
TB.char
instance TextBuildable String where
buildText :: String -> Builder
buildText = String -> Builder
TB.string
instance TextBuildable Text where
buildText :: Text -> Builder
buildText = Text -> Builder
TB.text
instance TextBuildable Builder where
buildText :: Builder -> Builder
buildText = forall a. a -> a
id
buildTextFromList :: TextBuildable a => [a] -> Builder
buildTextFromList :: forall a. TextBuildable a => [a] -> Builder
buildTextFromList [a]
ss = Builder
"[" forall a. Semigroup a => a -> a -> a
<> forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TB.intercalate Builder
", " (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. TextBuildable a => a -> Builder
buildText [a]
ss) forall a. Semigroup a => a -> a -> a
<> Builder
"]"
instance TextBuildable a => TextBuildable [a] where
buildText :: [a] -> Builder
buildText = forall a. TextBuildable a => [a] -> Builder
buildTextFromList
instance TextBuildable a => TextBuildable (Seq a) where
buildText :: Seq a -> Builder
buildText = forall a. TextBuildable a => [a] -> Builder
buildTextFromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
newtype ShowTextBuildable a = ShowTextBuildable { forall a. ShowTextBuildable a -> a
unShowTextBuildable :: a }
instance Show a => TextBuildable (ShowTextBuildable a) where
buildText :: ShowTextBuildable a -> Builder
buildText = String -> Builder
TB.string forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowTextBuildable a -> a
unShowTextBuildable
class ExplainLabel l where
explainLabel :: l -> Builder
explainLabelText :: l -> Text
explainLabelText = Builder -> Text
TB.run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. ExplainLabel l => l -> Builder
explainLabel
instance ExplainLabel Void where
explainLabel :: Void -> Builder
explainLabel = 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 -> forall l. ExplainLabel l => l -> Builder
explainLabel TextLabel
l
CompoundTextLabelCustom l
l -> 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
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
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 = forall a. Void -> a
absurd
endMsg :: Text
endMsg :: Text
endMsg = Text
"end of stream"
tokB :: TextBuildable a => a -> Builder
tokB :: forall a. TextBuildable a => a -> Builder
tokB a
t = Builder
"token '" forall a. Semigroup a => a -> a -> a
<> forall a. TextBuildable a => a -> Builder
buildText a
t forall a. Semigroup a => a -> a -> a
<> Builder
"'"
tokT :: TextBuildable a => a -> Text
tokT :: forall a. TextBuildable a => a -> Text
tokT = Builder -> Text
TB.run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TextBuildable a => a -> Builder
tokB
mayTokT :: TextBuildable a => Maybe a -> Text
mayTokT :: forall a. TextBuildable a => Maybe a -> Text
mayTokT = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
endMsg forall a. TextBuildable a => a -> Text
tokT
chunkB :: TextBuildable a => a -> Builder
chunkB :: forall a. TextBuildable a => a -> Builder
chunkB a
k = Builder
"chunk \"" forall a. Semigroup a => a -> a -> a
<> forall a. TextBuildable a => a -> Builder
buildText a
k forall a. Semigroup a => a -> a -> a
<> Builder
"\""
chunkT :: TextBuildable a => a -> Text
chunkT :: forall a. TextBuildable a => a -> Text
chunkT = Builder -> Text
TB.run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TextBuildable a => a -> Builder
chunkB
mayChunkT :: TextBuildable a => Maybe a -> Text
mayChunkT :: forall a. TextBuildable a => Maybe a -> Text
mayChunkT = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
endMsg forall a. TextBuildable a => a -> Text
chunkT
instance (TextBuildable (Token s), TextBuildable (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" (forall a. a -> Maybe a
Just Text
endMsg) (forall a. a -> Maybe a
Just (forall a. TextBuildable a => a -> Text
tokT Token s
actTok))
RawError (Chunk s) (Token s)
RawErrorAnyToken ->
Text -> Maybe Text -> Maybe Text -> ErrorExplanation
ErrorExplanation Text
"failed to match any token" (forall a. a -> Maybe a
Just Text
"any token") (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" (forall a. a -> Maybe a
Just Text
"any chunk") (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" forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (forall a. TextBuildable a => Maybe a -> Text
mayTokT Maybe (Token s)
mayActTok))
RawErrorMatchToken Token s
expTok Maybe (Token s)
mayActTok ->
Text -> Maybe Text -> Maybe Text -> ErrorExplanation
ErrorExplanation Text
"failed to match token" (forall a. a -> Maybe a
Just (forall a. TextBuildable a => a -> Text
tokT Token s
expTok)) (forall a. a -> Maybe a
Just (forall a. TextBuildable a => Maybe a -> Text
mayTokT Maybe (Token s)
mayActTok))
RawErrorMatchChunk Chunk s
expChunk Maybe (Chunk s)
mayActChunk ->
Text -> Maybe Text -> Maybe Text -> ErrorExplanation
ErrorExplanation Text
"failed to match chunk" (forall a. a -> Maybe a
Just (forall a. TextBuildable a => a -> Text
chunkT Chunk s
expChunk)) (forall a. a -> Maybe a
Just (forall a. TextBuildable a => Maybe a -> 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" forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (forall a. TextBuildable a => Maybe a -> Text
mayTokT Maybe (Token s)
mayActTok))
RawErrorDropTokensWhile1 Maybe (Token s)
mayActTok ->
Text -> Maybe Text -> Maybe Text -> ErrorExplanation
ErrorExplanation Text
"failed to drop 1 or more tokens" forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (forall a. TextBuildable a => Maybe a -> Text
mayTokT Maybe (Token s)
mayActTok))
instance (TextBuildable (Token s), TextBuildable (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 -> forall e. ExplainError e => e -> ErrorExplanation
explainError StreamError s
se
CompoundErrorFail Text
msg -> Text -> Maybe Text -> Maybe Text -> ErrorExplanation
ErrorExplanation Text
msg forall a. Maybe a
Nothing forall a. Maybe a
Nothing
CompoundErrorCustom e
e -> forall e. ExplainError e => e -> ErrorExplanation
explainError e
e
type Explainable l s e = (PosStream s, ExplainLabel l, ExplainError e)
data ParseErrorExplanation p = ParseErrorExplanation
{ forall p. ParseErrorExplanation p -> Span p
peeSpan :: !(Span p)
, forall p. ParseErrorExplanation p -> Seq Text
peeContext :: !(Seq Text)
, forall p. ParseErrorExplanation p -> Maybe Text
peeDetails :: !(Maybe Text)
, forall p. ParseErrorExplanation p -> ErrorExplanation
peeErrExp :: !ErrorExplanation
} deriving (ParseErrorExplanation p -> ParseErrorExplanation p -> Bool
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
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 :: (TextBuildable (Token s), TextBuildable (Chunk s), Explainable l s e) => ParseError l s e -> ParseErrorExplanation (Pos s)
explainParseError :: forall s l e.
(TextBuildable (Token s), TextBuildable (Chunk s),
Explainable l s e) =>
ParseError l s e -> ParseErrorExplanation (Pos s)
explainParseError ParseError l s e
pe =
let (Maybe l
mayLab, Span (Pos s)
sp) = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. ExplainLabel l => l -> Text
explainLabelText (forall l s e. ParseError l s e -> Seq l
parseErrorEnclosingLabels ParseError l s e
pe)
mayDetails :: Maybe Text
mayDetails = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. ExplainLabel l => l -> Text
explainLabelText Maybe l
mayLab
errExp :: ErrorExplanation
errExp = forall e. ExplainError e => e -> ErrorExplanation
explainError (forall l s e. ParseError l s e -> CompoundError s e
peError ParseError l s e
pe)
in 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 :: forall p. HasLinePos p => Span p -> Builder
buildSpan (Span p
p1 p
p2) =
let l1 :: Line
l1 = forall p. HasLinePos p => p -> Line
viewLine p
p1
c1 :: Col
c1 = forall p. HasLinePos p => p -> Col
viewCol p
p1
l2 :: Line
l2 = forall p. HasLinePos p => p -> Line
viewLine p
p2
c2 :: Col
c2 = forall p. HasLinePos p => p -> Col
viewCol p
p2
r1 :: Builder
r1 = forall a. Integral a => a -> Builder
TB.decimal (forall a. Enum a => a -> a
succ Line
l1) forall a. Semigroup a => a -> a -> a
<> Builder
":" forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Builder
TB.decimal (forall a. Enum a => a -> a
succ Col
c1)
r2 :: Builder
r2 = forall a. Integral a => a -> Builder
TB.decimal (forall a. Enum a => a -> a
succ Line
l2) forall a. Semigroup a => a -> a -> a
<> Builder
":" forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Builder
TB.decimal (forall a. Enum a => a -> a
succ Col
c2)
in if Line
l1 forall a. Eq a => a -> a -> Bool
== Line
l2 Bool -> Bool -> Bool
&& Col
c1 forall a. Eq a => a -> a -> Bool
== Col
c2
then Builder
r1
else Builder
r1 forall a. Semigroup a => a -> a -> a
<> 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) = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
[ [Builder
"[Reason ] " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.text Text
reason]
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Builder
de -> [Builder
"[Details ] " forall a. Semigroup a => a -> a -> a
<> Builder
de]) Maybe Builder
mayDetails
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
ex -> [Builder
"[Expected] " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.text Text
ex]) Maybe Text
mayExpected
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
ac -> [Builder
"[Actual ] " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.text Text
ac]) Maybe Text
mayActual
]
buildParseErrorExplanation :: HasLinePos p => ParseErrorExplanation p -> Builder
buildParseErrorExplanation :: forall p. HasLinePos p => ParseErrorExplanation p -> Builder
buildParseErrorExplanation (ParseErrorExplanation Span p
sp Seq Text
context Maybe Text
mayDetails ErrorExplanation
errExp) =
let hd :: [Builder]
hd = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
[ [Builder
"[Pos ] " forall a. Semigroup a => a -> a -> a
<> forall p. HasLinePos p => Span p -> Builder
buildSpan Span p
sp]
, [Builder
"[Context ] " forall a. Semigroup a => a -> a -> a
<> forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TB.intercalate Builder
" > " (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Builder
TB.text (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Text
context)) | Bool -> Bool
not (forall a. Seq a -> Bool
Seq.null Seq Text
context)]
]
tl :: [Builder]
tl = Maybe Builder -> ErrorExplanation -> [Builder]
buildErrorExplanation (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Builder
TB.text Maybe Text
mayDetails) ErrorExplanation
errExp
in forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TB.intercalate Builder
"\n" ([Builder]
hd forall a. [a] -> [a] -> [a]
++ [Builder]
tl)
buildAllParseErrorExplanations :: (HasLinePos p, Foldable f) => f (ParseErrorExplanation p) -> Builder
buildAllParseErrorExplanations :: forall p (f :: * -> *).
(HasLinePos p, Foldable f) =>
f (ParseErrorExplanation p) -> Builder
buildAllParseErrorExplanations = forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TB.intercalate Builder
"\n\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall p. HasLinePos p => ParseErrorExplanation p -> Builder
buildParseErrorExplanation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList