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

-- | Types that can be rendered into a textual error message
-- (Effectively a fancy Show)
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

-- | Deriving-Via wrapper for 'TextBuildable' for types with 'Show'
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