{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      :  Text.Megaparsec.Error.Builder
-- Copyright   :  © 2015–present Megaparsec contributors
-- License     :  FreeBSD
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- A set of helpers that should make construction of 'ParseError's more
-- concise. This is primarily useful in test suites and for debugging.
--
-- @since 6.0.0
module Text.Megaparsec.Error.Builder
  ( -- * Top-level helpers
    err,
    errFancy,

    -- * Error components
    utok,
    utoks,
    ulabel,
    ueof,
    etok,
    etoks,
    elabel,
    eeof,
    fancy,

    -- * Data types
    ET,
    EF,
  )
where

import Data.Data (Data)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as E
import Data.Typeable (Typeable)
import GHC.Generics
import Text.Megaparsec.Error
import Text.Megaparsec.Stream

----------------------------------------------------------------------------
-- Data types

-- | Auxiliary type for construction of trivial parse errors.
data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))
  deriving (Typeable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (ET s) x -> ET s
forall s x. ET s -> Rep (ET s) x
$cto :: forall s x. Rep (ET s) x -> ET s
$cfrom :: forall s x. ET s -> Rep (ET s) x
Generic)

deriving instance (Eq (Token s)) => Eq (ET s)

deriving instance (Ord (Token s)) => Ord (ET s)

deriving instance
  ( Data s,
    Data (Token s),
    Ord (Token s)
  ) =>
  Data (ET s)

instance (Stream s) => Semigroup (ET s) where
  ET Maybe (ErrorItem (Token s))
us0 Set (ErrorItem (Token s))
ps0 <> :: ET s -> ET s -> ET s
<> ET Maybe (ErrorItem (Token s))
us1 Set (ErrorItem (Token s))
ps1 = forall s.
Maybe (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> ET s
ET (forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
n Maybe (ErrorItem (Token s))
us0 Maybe (ErrorItem (Token s))
us1) (forall a. Ord a => Set a -> Set a -> Set a
E.union Set (ErrorItem (Token s))
ps0 Set (ErrorItem (Token s))
ps1)
    where
      n :: Maybe a -> Maybe a -> Maybe a
n Maybe a
Nothing Maybe a
Nothing = forall a. Maybe a
Nothing
      n (Just a
x) Maybe a
Nothing = forall a. a -> Maybe a
Just a
x
      n Maybe a
Nothing (Just a
y) = forall a. a -> Maybe a
Just a
y
      n (Just a
x) (Just a
y) = forall a. a -> Maybe a
Just (forall a. Ord a => a -> a -> a
max a
x a
y)

instance (Stream s) => Monoid (ET s) where
  mempty :: ET s
mempty = forall s.
Maybe (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> ET s
ET forall a. Maybe a
Nothing forall a. Set a
E.empty
  mappend :: ET s -> ET s -> ET s
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Auxiliary type for construction of fancy parse errors.
newtype EF e = EF (Set (ErrorFancy e))
  deriving (EF e -> EF e -> Bool
forall e. Eq e => EF e -> EF e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EF e -> EF e -> Bool
$c/= :: forall e. Eq e => EF e -> EF e -> Bool
== :: EF e -> EF e -> Bool
$c== :: forall e. Eq e => EF e -> EF e -> Bool
Eq, EF e -> EF e -> Bool
EF e -> EF e -> Ordering
EF e -> EF e -> EF e
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {e}. Ord e => Eq (EF e)
forall e. Ord e => EF e -> EF e -> Bool
forall e. Ord e => EF e -> EF e -> Ordering
forall e. Ord e => EF e -> EF e -> EF e
min :: EF e -> EF e -> EF e
$cmin :: forall e. Ord e => EF e -> EF e -> EF e
max :: EF e -> EF e -> EF e
$cmax :: forall e. Ord e => EF e -> EF e -> EF e
>= :: EF e -> EF e -> Bool
$c>= :: forall e. Ord e => EF e -> EF e -> Bool
> :: EF e -> EF e -> Bool
$c> :: forall e. Ord e => EF e -> EF e -> Bool
<= :: EF e -> EF e -> Bool
$c<= :: forall e. Ord e => EF e -> EF e -> Bool
< :: EF e -> EF e -> Bool
$c< :: forall e. Ord e => EF e -> EF e -> Bool
compare :: EF e -> EF e -> Ordering
$ccompare :: forall e. Ord e => EF e -> EF e -> Ordering
Ord, EF e -> DataType
EF e -> Constr
forall {e}. (Data e, Ord e) => Typeable (EF e)
forall e. (Data e, Ord e) => EF e -> DataType
forall e. (Data e, Ord e) => EF e -> Constr
forall e.
(Data e, Ord e) =>
(forall b. Data b => b -> b) -> EF e -> EF e
forall e u.
(Data e, Ord e) =>
Int -> (forall d. Data d => d -> u) -> EF e -> u
forall e u.
(Data e, Ord e) =>
(forall d. Data d => d -> u) -> EF e -> [u]
forall e r r'.
(Data e, Ord e) =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> EF e -> r
forall e r r'.
(Data e, Ord e) =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> EF e -> r
forall e (m :: * -> *).
(Data e, Ord e, Monad m) =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
forall e (m :: * -> *).
(Data e, Ord e, MonadPlus m) =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
forall e (c :: * -> *).
(Data e, Ord e) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (EF e)
forall e (c :: * -> *).
(Data e, Ord e) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EF e -> c (EF e)
forall e (t :: * -> *) (c :: * -> *).
(Data e, Ord e, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (EF e))
forall e (t :: * -> * -> *) (c :: * -> *).
(Data e, Ord e, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (EF e))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (EF e)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EF e -> c (EF e)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (EF e))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
$cgmapMo :: forall e (m :: * -> *).
(Data e, Ord e, MonadPlus m) =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
$cgmapMp :: forall e (m :: * -> *).
(Data e, Ord e, MonadPlus m) =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
$cgmapM :: forall e (m :: * -> *).
(Data e, Ord e, Monad m) =>
(forall d. Data d => d -> m d) -> EF e -> m (EF e)
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> EF e -> u
$cgmapQi :: forall e u.
(Data e, Ord e) =>
Int -> (forall d. Data d => d -> u) -> EF e -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> EF e -> [u]
$cgmapQ :: forall e u.
(Data e, Ord e) =>
(forall d. Data d => d -> u) -> EF e -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> EF e -> r
$cgmapQr :: forall e r r'.
(Data e, Ord e) =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> EF e -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> EF e -> r
$cgmapQl :: forall e r r'.
(Data e, Ord e) =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> EF e -> r
gmapT :: (forall b. Data b => b -> b) -> EF e -> EF e
$cgmapT :: forall e.
(Data e, Ord e) =>
(forall b. Data b => b -> b) -> EF e -> EF e
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (EF e))
$cdataCast2 :: forall e (t :: * -> * -> *) (c :: * -> *).
(Data e, Ord e, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (EF e))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (EF e))
$cdataCast1 :: forall e (t :: * -> *) (c :: * -> *).
(Data e, Ord e, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (EF e))
dataTypeOf :: EF e -> DataType
$cdataTypeOf :: forall e. (Data e, Ord e) => EF e -> DataType
toConstr :: EF e -> Constr
$ctoConstr :: forall e. (Data e, Ord e) => EF e -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (EF e)
$cgunfold :: forall e (c :: * -> *).
(Data e, Ord e) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (EF e)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EF e -> c (EF e)
$cgfoldl :: forall e (c :: * -> *).
(Data e, Ord e) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EF e -> c (EF e)
Data, Typeable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e x. Rep (EF e) x -> EF e
forall e x. EF e -> Rep (EF e) x
$cto :: forall e x. Rep (EF e) x -> EF e
$cfrom :: forall e x. EF e -> Rep (EF e) x
Generic)

instance (Ord e) => Semigroup (EF e) where
  EF Set (ErrorFancy e)
xs0 <> :: EF e -> EF e -> EF e
<> EF Set (ErrorFancy e)
xs1 = forall e. Set (ErrorFancy e) -> EF e
EF (forall a. Ord a => Set a -> Set a -> Set a
E.union Set (ErrorFancy e)
xs0 Set (ErrorFancy e)
xs1)

instance (Ord e) => Monoid (EF e) where
  mempty :: EF e
mempty = forall e. Set (ErrorFancy e) -> EF e
EF forall a. Set a
E.empty
  mappend :: EF e -> EF e -> EF e
mappend = forall a. Semigroup a => a -> a -> a
(<>)

----------------------------------------------------------------------------
-- Top-level helpers

-- | Assemble a 'ParseError' from the offset and the @'ET' t@ value. @'ET'
-- t@ is a monoid and can be assembled by combining primitives provided by
-- this module, see below.
err ::
  -- | 'ParseError' offset
  Int ->
  -- | Error components
  ET s ->
  -- | Resulting 'ParseError'
  ParseError s e
err :: forall s e. Int -> ET s -> ParseError s e
err Int
p (ET Maybe (ErrorItem (Token s))
us Set (ErrorItem (Token s))
ps) = forall s e.
Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
TrivialError Int
p Maybe (ErrorItem (Token s))
us Set (ErrorItem (Token s))
ps

-- | Like 'err', but constructs a “fancy” 'ParseError'.
errFancy ::
  -- | 'ParseError' offset
  Int ->
  -- | Error components
  EF e ->
  -- | Resulting 'ParseError'
  ParseError s e
errFancy :: forall e s. Int -> EF e -> ParseError s e
errFancy Int
p (EF Set (ErrorFancy e)
xs) = forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
p Set (ErrorFancy e)
xs

----------------------------------------------------------------------------
-- Error components

-- | Construct an “unexpected token” error component.
utok :: Token s -> ET s
utok :: forall s. Token s -> ET s
utok = forall s. ErrorItem (Token s) -> ET s
unexp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. NonEmpty t -> ErrorItem t
Tokens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a
nes

-- | Construct an “unexpected tokens” error component. Empty chunk produces
-- 'EndOfInput'.
utoks :: forall s. (Stream s) => Tokens s -> ET s
utoks :: forall s. Stream s => Tokens s -> ET s
utoks = forall s. ErrorItem (Token s) -> ET s
unexp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Stream s => Proxy s -> Tokens s -> ErrorItem (Token s)
canonicalizeTokens (forall {k} (t :: k). Proxy t
Proxy :: Proxy s)

-- | Construct an “unexpected label” error component. Do not use with empty
-- strings (for empty strings it's bottom).
ulabel :: String -> ET s
ulabel :: forall s. String -> ET s
ulabel String
label
  | String
label forall a. Eq a => a -> a -> Bool
== String
"" = forall a. HasCallStack => String -> a
error String
"Text.Megaparsec.Error.Builder.ulabel: empty label"
  | Bool
otherwise = forall s. ErrorItem (Token s) -> ET s
unexp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. NonEmpty Char -> ErrorItem t
Label forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$ String
label

-- | Construct an “unexpected end of input” error component.
ueof :: ET s
ueof :: forall s. ET s
ueof = forall s. ErrorItem (Token s) -> ET s
unexp forall t. ErrorItem t
EndOfInput

-- | Construct an “expected token” error component.
etok :: Token s -> ET s
etok :: forall s. Token s -> ET s
etok = forall s. ErrorItem (Token s) -> ET s
expe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. NonEmpty t -> ErrorItem t
Tokens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a
nes

-- | Construct an “expected tokens” error component. Empty chunk produces
-- 'EndOfInput'.
etoks :: forall s. (Stream s) => Tokens s -> ET s
etoks :: forall s. Stream s => Tokens s -> ET s
etoks = forall s. ErrorItem (Token s) -> ET s
expe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Stream s => Proxy s -> Tokens s -> ErrorItem (Token s)
canonicalizeTokens (forall {k} (t :: k). Proxy t
Proxy :: Proxy s)

-- | Construct an “expected label” error component. Do not use with empty
-- strings.
elabel :: String -> ET s
elabel :: forall s. String -> ET s
elabel String
label
  | String
label forall a. Eq a => a -> a -> Bool
== String
"" = forall a. HasCallStack => String -> a
error String
"Text.Megaparsec.Error.Builder.elabel: empty label"
  | Bool
otherwise = forall s. ErrorItem (Token s) -> ET s
expe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. NonEmpty Char -> ErrorItem t
Label forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$ String
label

-- | Construct an “expected end of input” error component.
eeof :: ET s
eeof :: forall s. ET s
eeof = forall s. ErrorItem (Token s) -> ET s
expe forall t. ErrorItem t
EndOfInput

-- | Construct a custom error component.
fancy :: ErrorFancy e -> EF e
fancy :: forall e. ErrorFancy e -> EF e
fancy = forall e. Set (ErrorFancy e) -> EF e
EF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Set a
E.singleton

----------------------------------------------------------------------------
-- Helpers

-- | Construct the appropriate 'ErrorItem' representation for the given
-- token stream. The empty string produces 'EndOfInput'.
canonicalizeTokens ::
  (Stream s) =>
  Proxy s ->
  Tokens s ->
  ErrorItem (Token s)
canonicalizeTokens :: forall s. Stream s => Proxy s -> Tokens s -> ErrorItem (Token s)
canonicalizeTokens Proxy s
pxy Tokens s
ts =
  case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens Proxy s
pxy Tokens s
ts) of
    Maybe (NonEmpty (Token s))
Nothing -> forall t. ErrorItem t
EndOfInput
    Just NonEmpty (Token s)
xs -> forall t. NonEmpty t -> ErrorItem t
Tokens NonEmpty (Token s)
xs

-- | Lift an unexpected item into 'ET'.
unexp :: ErrorItem (Token s) -> ET s
unexp :: forall s. ErrorItem (Token s) -> ET s
unexp ErrorItem (Token s)
u = forall s.
Maybe (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> ET s
ET (forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorItem (Token s)
u) forall a. Set a
E.empty

-- | Lift an expected item into 'ET'.
expe :: ErrorItem (Token s) -> ET s
expe :: forall s. ErrorItem (Token s) -> ET s
expe ErrorItem (Token s)
p = forall s.
Maybe (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> ET s
ET forall a. Maybe a
Nothing (forall a. a -> Set a
E.singleton ErrorItem (Token s)
p)

-- | Make a singleton non-empty list from a value.
nes :: a -> NonEmpty a
nes :: forall a. a -> NonEmpty a
nes a
x = a
x forall a. a -> [a] -> NonEmpty a
:| []