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