{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Text.Megaparsec.ErrorList
(
ErrorItem (..),
ErrorFancy (..),
ParseError (..),
mapParseError,
errorOffset,
setErrorOffset,
ParseErrorBundle (..),
attachSourcePos,
ShowErrorComponent (..),
parseErrorPretty,
parseErrorTextPretty,
showErrorItem,
)
where
import Control.DeepSeq
import Control.Monad.State.Strict
import Data.Data (Data)
import Data.Foldable (toList)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isNothing)
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as E
import Data.Typeable (Typeable)
import Data.Void
import GHC.Generics
import Text.Megaparsec.Error (ErrorFancy (ErrorCustom, ErrorFail, ErrorIndentation), ErrorItem (EndOfInput, Label, Tokens), ParseError (FancyError, TrivialError))
import Text.Megaparsec.Pos
import Text.Megaparsec.State
import Text.Megaparsec.Stream hiding (VisualStream (..))
mapParseError ::
(Ord e') =>
(e -> e') ->
ParseError s e ->
ParseError s e'
mapParseError :: forall e' e s.
Ord e' =>
(e -> e') -> ParseError s e -> ParseError s e'
mapParseError e -> e'
_ (TrivialError Int
o Maybe (ErrorItem (Token s))
u Set (ErrorItem (Token s))
p) = Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e'
forall s e.
Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
TrivialError Int
o Maybe (ErrorItem (Token s))
u Set (ErrorItem (Token s))
p
mapParseError e -> e'
f (FancyError Int
o Set (ErrorFancy e)
x) = Int -> Set (ErrorFancy e') -> ParseError s e'
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
o ((ErrorFancy e -> ErrorFancy e')
-> Set (ErrorFancy e) -> Set (ErrorFancy e')
forall b a. Ord b => (a -> b) -> Set a -> Set b
E.map ((e -> e') -> ErrorFancy e -> ErrorFancy e'
forall a b. (a -> b) -> ErrorFancy a -> ErrorFancy b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e'
f) Set (ErrorFancy e)
x)
errorOffset :: ParseError s e -> Int
errorOffset :: forall s e. ParseError s e -> Int
errorOffset (TrivialError Int
o Maybe (ErrorItem (Token s))
_ Set (ErrorItem (Token s))
_) = Int
o
errorOffset (FancyError Int
o Set (ErrorFancy e)
_) = Int
o
setErrorOffset :: Int -> ParseError s e -> ParseError s e
setErrorOffset :: forall s e. Int -> ParseError s e -> ParseError s e
setErrorOffset Int
o (TrivialError Int
_ Maybe (ErrorItem (Token s))
u Set (ErrorItem (Token s))
p) = Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
forall s e.
Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
TrivialError Int
o Maybe (ErrorItem (Token s))
u Set (ErrorItem (Token s))
p
setErrorOffset Int
o (FancyError Int
_ Set (ErrorFancy e)
x) = Int -> Set (ErrorFancy e) -> ParseError s e
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
o Set (ErrorFancy e)
x
data ParseErrorBundle s e = ParseErrorBundle
{
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors :: NonEmpty (ParseError s e),
forall s e. ParseErrorBundle s e -> PosState s
bundlePosState :: PosState s
}
deriving ((forall x. ParseErrorBundle s e -> Rep (ParseErrorBundle s e) x)
-> (forall x. Rep (ParseErrorBundle s e) x -> ParseErrorBundle s e)
-> Generic (ParseErrorBundle s e)
forall x. Rep (ParseErrorBundle s e) x -> ParseErrorBundle s e
forall x. ParseErrorBundle s e -> Rep (ParseErrorBundle s e) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s e x. Rep (ParseErrorBundle s e) x -> ParseErrorBundle s e
forall s e x. ParseErrorBundle s e -> Rep (ParseErrorBundle s e) x
$cfrom :: forall s e x. ParseErrorBundle s e -> Rep (ParseErrorBundle s e) x
from :: forall x. ParseErrorBundle s e -> Rep (ParseErrorBundle s e) x
$cto :: forall s e x. Rep (ParseErrorBundle s e) x -> ParseErrorBundle s e
to :: forall x. Rep (ParseErrorBundle s e) x -> ParseErrorBundle s e
Generic)
deriving instance
( Show s,
Show (Token s),
Show e
) =>
Show (ParseErrorBundle s e)
deriving instance
( Eq s,
Eq (Token s),
Eq e
) =>
Eq (ParseErrorBundle s e)
deriving instance
( Typeable s,
Typeable (Token s),
Typeable e
) =>
Typeable (ParseErrorBundle s e)
deriving instance
( Data s,
Data (Token s),
Ord (Token s),
Data e,
Ord e
) =>
Data (ParseErrorBundle s e)
instance
( NFData s,
NFData (Token s),
NFData e
) =>
NFData (ParseErrorBundle s e)
attachSourcePos ::
(Traversable t, TraversableStream s) =>
(a -> Int) ->
t a ->
PosState s ->
(t (a, SourcePos), PosState s)
attachSourcePos :: forall (t :: * -> *) s a.
(Traversable t, TraversableStream s) =>
(a -> Int) -> t a -> PosState s -> (t (a, SourcePos), PosState s)
attachSourcePos a -> Int
projectOffset t a
xs = State (PosState s) (t (a, SourcePos))
-> PosState s -> (t (a, SourcePos), PosState s)
forall s a. State s a -> s -> (a, s)
runState ((a -> StateT (PosState s) Identity (a, SourcePos))
-> t a -> State (PosState s) (t (a, SourcePos))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse a -> StateT (PosState s) Identity (a, SourcePos)
forall {m :: * -> *} {s}.
(MonadState (PosState s) m, TraversableStream s) =>
a -> m (a, SourcePos)
f t a
xs)
where
f :: a -> m (a, SourcePos)
f a
a = do
PosState s
pst <- m (PosState s)
forall s (m :: * -> *). MonadState s m => m s
get
let pst' :: PosState s
pst' = Int -> PosState s -> PosState s
forall s. TraversableStream s => Int -> PosState s -> PosState s
reachOffsetNoLine (a -> Int
projectOffset a
a) PosState s
pst
PosState s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PosState s
pst'
(a, SourcePos) -> m (a, SourcePos)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, PosState s -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos PosState s
pst')
{-# INLINEABLE attachSourcePos #-}
class (Ord a) => ShowErrorComponent a where
showErrorComponent :: a -> String
errorComponentLen :: a -> Int
errorComponentLen a
_ = Int
1
instance ShowErrorComponent Void where
showErrorComponent :: Void -> String
showErrorComponent = Void -> String
forall a. Void -> a
absurd
parseErrorPretty ::
(Show (Token s), ShowErrorComponent e) =>
ParseError s e ->
String
parseErrorPretty :: forall s e.
(Show (Token s), ShowErrorComponent e) =>
ParseError s e -> String
parseErrorPretty ParseError s e
e =
String
"offset=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ParseError s e -> Int
forall s e. ParseError s e -> Int
errorOffset ParseError s e
e) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ParseError s e -> String
forall s e.
(Show (Token s), ShowErrorComponent e) =>
ParseError s e -> String
parseErrorTextPretty ParseError s e
e
parseErrorTextPretty ::
forall s e.
(Show (Token s), ShowErrorComponent e) =>
ParseError s e ->
String
parseErrorTextPretty :: forall s e.
(Show (Token s), ShowErrorComponent e) =>
ParseError s e -> String
parseErrorTextPretty (TrivialError Int
_ Maybe (ErrorItem (Token s))
us Set (ErrorItem (Token s))
ps) =
if Maybe (ErrorItem (Token s)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (ErrorItem (Token s))
us Bool -> Bool -> Bool
&& Set (ErrorItem (Token s)) -> Bool
forall a. Set a -> Bool
E.null Set (ErrorItem (Token s))
ps
then String
"unknown parse error\n"
else
String -> Set String -> String
messageItemsPretty String
"unexpected " (Proxy s -> ErrorItem (Token s) -> String
forall s.
Show (Token s) =>
Proxy s -> ErrorItem (Token s) -> String
showErrorItem Proxy s
pxy (ErrorItem (Token s) -> String)
-> Set (ErrorItem (Token s)) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
`E.map` Set (ErrorItem (Token s))
-> (ErrorItem (Token s) -> Set (ErrorItem (Token s)))
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set (ErrorItem (Token s))
forall a. Set a
E.empty ErrorItem (Token s) -> Set (ErrorItem (Token s))
forall a. a -> Set a
E.singleton Maybe (ErrorItem (Token s))
us)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Set String -> String
messageItemsPretty String
"expecting " (Proxy s -> ErrorItem (Token s) -> String
forall s.
Show (Token s) =>
Proxy s -> ErrorItem (Token s) -> String
showErrorItem Proxy s
pxy (ErrorItem (Token s) -> String)
-> Set (ErrorItem (Token s)) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
`E.map` Set (ErrorItem (Token s))
ps)
where
pxy :: Proxy s
pxy = Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s
parseErrorTextPretty (FancyError Int
_ Set (ErrorFancy e)
xs) =
if Set (ErrorFancy e) -> Bool
forall a. Set a -> Bool
E.null Set (ErrorFancy e)
xs
then String
"unknown fancy parse error\n"
else [String] -> String
unlines (ErrorFancy e -> String
forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy (ErrorFancy e -> String) -> [ErrorFancy e] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (ErrorFancy e) -> [ErrorFancy e]
forall a. Set a -> [a]
E.toAscList Set (ErrorFancy e)
xs)
showErrorItem :: (Show (Token s)) => Proxy s -> ErrorItem (Token s) -> String
showErrorItem :: forall s.
Show (Token s) =>
Proxy s -> ErrorItem (Token s) -> String
showErrorItem Proxy s
pxy = \case
Tokens NonEmpty (Token s)
ts -> Proxy s -> NonEmpty (Token s) -> String
forall s. Show (Token s) => Proxy s -> NonEmpty (Token s) -> String
showTokens Proxy s
pxy NonEmpty (Token s)
ts
Label NonEmpty Char
label -> NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Char
label
ErrorItem (Token s)
EndOfInput -> String
"end of input"
showErrorFancy :: (ShowErrorComponent e) => ErrorFancy e -> String
showErrorFancy :: forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy = \case
ErrorFail String
msg -> String
msg
ErrorIndentation Ordering
ord Pos
ref Pos
actual ->
String
"incorrect indentation (got "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
actual)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", should be "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
p
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
ref)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
where
p :: String
p = case Ordering
ord of
Ordering
LT -> String
"less than "
Ordering
EQ -> String
"equal to "
Ordering
GT -> String
"greater than "
ErrorCustom e
a -> e -> String
forall a. ShowErrorComponent a => a -> String
showErrorComponent e
a
messageItemsPretty ::
String ->
Set String ->
String
messageItemsPretty :: String -> Set String -> String
messageItemsPretty String
prefix Set String
ts
| Set String -> Bool
forall a. Set a -> Bool
E.null Set String
ts = String
""
| Bool
otherwise =
String
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (NonEmpty String -> String
orList (NonEmpty String -> String)
-> (Set String -> NonEmpty String) -> Set String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> NonEmpty String
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([String] -> NonEmpty String)
-> (Set String -> [String]) -> Set String -> NonEmpty String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> [String]
forall a. Set a -> [a]
E.toAscList) Set String
ts String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
orList :: NonEmpty String -> String
orList :: NonEmpty String -> String
orList (String
x :| []) = String
x
orList (String
x :| [String
y]) = String
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" or " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
y
orList NonEmpty String
xs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.init NonEmpty String
xs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", or " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> String
forall a. NonEmpty a -> a
NE.last NonEmpty String
xs
showTokens :: (Show (Token s)) => Proxy s -> NonEmpty (Token s) -> String
showTokens :: forall s. Show (Token s) => Proxy s -> NonEmpty (Token s) -> String
showTokens Proxy s
_ =
((String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"")) ShowS
-> (NonEmpty (Token s) -> String) -> NonEmpty (Token s) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String)
-> (NonEmpty (Token s) -> [String]) -> NonEmpty (Token s) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")")) ([String] -> [String])
-> (NonEmpty (Token s) -> [String])
-> NonEmpty (Token s)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Token s -> String) -> [Token s] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token s -> String
forall a. Show a => a -> String
show ([Token s] -> [String])
-> (NonEmpty (Token s) -> [Token s])
-> NonEmpty (Token s)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
NonEmpty (Token s) -> [Token s]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList