{-# 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