{-# LANGUAGE Safe #-}
{-# LANGUAGE OverloadedLists, RecordWildCards #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}
{-|
Module      : Text.Gigaparsec.Expr
Description : This module can be used to generate hand-tuned error messages without using monadic bind.
License     : BSD-3-Clause
Maintainer  : Jamie Willis, Gigaparsec Maintainers
Stability   : experimental

This module can be used to generate hand-tuned error messages without using monadic bind.

-}
module Text.Gigaparsec.Errors.ErrorGen (
    -- * Documentation
    -- ** Error Generators
    ErrorGen(..),
    UnexpectedItem(..), 
    -- *** Blank Generators
    vanillaGen, specializedGen,
    -- ** Error Generating Combinators
    {-|
    These combinators create parsers that fail or raise errors with messages desribed by a given 'ErrorGen'.
    -}
    asFail, asSelect, asErr, 
  ) where
import Text.Gigaparsec.Internal (Parsec)
import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), State, specialisedErr, emptyErr, expectedErr, unexpectedErr, raise)
import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, CaretWidth(RigidCaret), addReason)

{-|
This type describes special primitives that can use the results of a previous parser 
to form and raise an error message. 
This is not something that is normally possible with raw combinators, without using '(>>=)', 
which is expensive.

Primarily, these are designed to be used with 
'Text.Gigaparsec.Errors.Combinator.filterSWith'\/'Text.Gigaparsec.Errors.Patterns.verifiedWith'\/'Text.Gigaparsec.Errors.Patterns.preventWith'
but can be used in other parsers as well. 
-}
type ErrorGen :: * -> *
data ErrorGen a 
  -- | An error generator for /Specialized/ errors, which can tune the freeform messages of the error.
  = SpecializedGen { 
      -- | Produces the messages of the error message when given the result of the offending parser. 
      forall a. ErrorGen a -> a -> [String]
messages :: a -> [String] -- FIXME: 0.3.0.0 change to NonEmptyList.
      -- | Controls how wide an error is based on the value @a@ and width @Word@ provided.
    , forall a. ErrorGen a -> a -> Word -> Word
adjustWidth :: a -> Word -> Word
    }
  -- | An error generator for /Vanilla/ errors, which can tune the unexpected message and a generated reason.
  | VanillaGen { 
      -- | Produces the unexpected component (if any) of the error message when given the result of the offending parser.
      forall a. ErrorGen a -> a -> UnexpectedItem
unexpected :: a -> UnexpectedItem
      -- | Produces the reason component (if any) of the error message when given the result of the offending parser.
    , forall a. ErrorGen a -> a -> Maybe String
reason :: a -> Maybe String
    , adjustWidth :: a -> Word -> Word
    }

-- | A blank /Vanilla/ error generator, which does not affect the unexpected message or reason.
vanillaGen :: ErrorGen a
vanillaGen :: forall a. ErrorGen a
vanillaGen = VanillaGen { unexpected :: a -> UnexpectedItem
unexpected = UnexpectedItem -> a -> UnexpectedItem
forall a b. a -> b -> a
const UnexpectedItem
EmptyItem
                        , reason :: a -> Maybe String
reason = Maybe String -> a -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing
                        , adjustWidth :: a -> Word -> Word
adjustWidth = (Word -> Word) -> a -> Word -> Word
forall a b. a -> b -> a
const Word -> Word
forall a. a -> a
id
                        }

-- | The default /Specialized/ error generator, which does not affect the error message.
specializedGen :: ErrorGen a
specializedGen :: forall a. ErrorGen a
specializedGen = SpecializedGen { messages :: a -> [String]
messages = [String] -> a -> [String]
forall a b. a -> b -> a
const []
                                , adjustWidth :: a -> Word -> Word
adjustWidth = (Word -> Word) -> a -> Word -> Word
forall a b. a -> b -> a
const Word -> Word
forall a. a -> a
id
                                }

{-|
This type describes how to form the unexpected component of a vanilla error message from a 'VanillaGen'.

This includes the different sorts of 'unexpected item' messages that may occur;
whether to display the expected characters, a name for the expected expression, or not to display at all.
-}
type UnexpectedItem :: *
data UnexpectedItem 
  -- | The error should use whatever input was consumed by the offending parser, verbatim.
  = RawItem 
  -- | The error should not have an unexpected component at all (as in 'Text.Gigaparsec.filterS').
  | EmptyItem 
  -- | The error should use the given name as the unexpected component.
  | NamedItem String

{-|
Given a parser result and its width, raise an error according to the given error generator.
-}
asErr :: ErrorGen a -- ^ @errGen@, the generator for the error message to raise.
      -> a          -- ^ @x@, the result of the offending parser
      -> Word       -- ^ The width of the parsed result, @x@.
      -> Parsec b   -- ^ A parser that unconditionally raises an error described by @errGen@.
asErr :: forall a b. ErrorGen a -> a -> Word -> Parsec b
asErr ErrorGen a
errGen a
x Word
w = (State -> Error) -> Parsec b
forall a. (State -> Error) -> Parsec a
Internal.raise ((State -> Error) -> Parsec b) -> (State -> Error) -> Parsec b
forall a b. (a -> b) -> a -> b
$ \State
st -> ErrorGen a -> State -> a -> Word -> Error
forall a. ErrorGen a -> State -> a -> Word -> Error
genErr ErrorGen a
errGen State
st a
x Word
w

{-|
This combinator takes a given parser @p@ and unconditionally fails with a message based on @p@'s results.
-}
asFail  :: ErrorGen a       -- ^ @errGen@, the generator for the error message.
        -> Parsec (a, Word) -- ^ @p@, a parser that returns a result @x@ and its width @w@.
        -> Parsec b         -- ^ A parser that unconditionally fails with a message described by @errGen@, 
                            --   using the result of @p@.
asFail :: forall a b. ErrorGen a -> Parsec (a, Word) -> Parsec b
asFail ErrorGen a
errGen (Internal.Parsec forall r.
State
-> ((a, Word) -> State -> RT r) -> (Error -> State -> RT r) -> RT r
p) = (forall r.
 State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec b
forall a.
(forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
Internal.Parsec ((forall r.
  State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
 -> Parsec b)
-> (forall r.
    State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec b
forall a b. (a -> b) -> a -> b
$ \State
st b -> State -> RT r
_ Error -> State -> RT r
bad ->
  let good :: (a, Word) -> State -> RT r
good (a
x, Word
w) State
st' = Error -> State -> RT r
bad (ErrorGen a -> State -> a -> Word -> Error
forall a. ErrorGen a -> State -> a -> Word -> Error
genErr ErrorGen a
errGen State
st' a
x Word
w) State
st'
  in  State
-> ((a, Word) -> State -> RT r) -> (Error -> State -> RT r) -> RT r
forall r.
State
-> ((a, Word) -> State -> RT r) -> (Error -> State -> RT r) -> RT r
p State
st (a, Word) -> State -> RT r
good Error -> State -> RT r
bad

{-|
This combinator takes a given parser @p@ and, if @p@ returns an @a@, 
fails with a message based on this result.
-}
asSelect  :: ErrorGen a                  -- ^ @errGen@, the generator for the error message.
          -> Parsec (Either (a, Word) b) -- ^ @p@, a parser which may produce a bad result of type @a@
          -> Parsec b                    -- ^ A parser that fails if @p@ produces a bad result, 
                                         --   otherwise returns the result of @p@ if it is a @b@
asSelect :: forall a b. ErrorGen a -> Parsec (Either (a, Word) b) -> Parsec b
asSelect ErrorGen a
errGen (Internal.Parsec forall r.
State
-> (Either (a, Word) b -> State -> RT r)
-> (Error -> State -> RT r)
-> RT r
p) = (forall r.
 State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec b
forall a.
(forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
Internal.Parsec ((forall r.
  State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
 -> Parsec b)
-> (forall r.
    State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec b
forall a b. (a -> b) -> a -> b
$ \State
st b -> State -> RT r
good Error -> State -> RT r
bad ->
  let good' :: Either (a, Word) b -> State -> RT r
good' (Right b
x) State
st' = b -> State -> RT r
good b
x State
st'
      good' (Left (a
x, Word
w)) State
st' = Error -> State -> RT r
bad (ErrorGen a -> State -> a -> Word -> Error
forall a. ErrorGen a -> State -> a -> Word -> Error
genErr ErrorGen a
errGen State
st' a
x Word
w) State
st'
  in State
-> (Either (a, Word) b -> State -> RT r)
-> (Error -> State -> RT r)
-> RT r
forall r.
State
-> (Either (a, Word) b -> State -> RT r)
-> (Error -> State -> RT r)
-> RT r
p State
st Either (a, Word) b -> State -> RT r
good' Error -> State -> RT r
bad

genErr :: ErrorGen a -> Internal.State -> a -> Word -> Internal.Error
genErr :: forall a. ErrorGen a -> State -> a -> Word -> Error
genErr SpecializedGen{a -> [String]
a -> Word -> Word
messages :: forall a. ErrorGen a -> a -> [String]
adjustWidth :: forall a. ErrorGen a -> a -> Word -> Word
messages :: a -> [String]
adjustWidth :: a -> Word -> Word
..} State
st a
x Word
w =
  State -> [String] -> CaretWidth -> Error
Internal.specialisedErr State
st (a -> [String]
messages a
x) (Word -> CaretWidth
Internal.RigidCaret (a -> Word -> Word
adjustWidth a
x Word
w))
genErr VanillaGen{a -> Maybe String
a -> UnexpectedItem
a -> Word -> Word
adjustWidth :: forall a. ErrorGen a -> a -> Word -> Word
unexpected :: forall a. ErrorGen a -> a -> UnexpectedItem
reason :: forall a. ErrorGen a -> a -> Maybe String
unexpected :: a -> UnexpectedItem
reason :: a -> Maybe String
adjustWidth :: a -> Word -> Word
..} State
st a
x Word
w =
  Maybe String -> Error -> Error
addReason (a -> Maybe String
reason a
x) (UnexpectedItem -> State -> Word -> Error
makeError (a -> UnexpectedItem
unexpected a
x) State
st (a -> Word -> Word
adjustWidth a
x Word
w))

makeError :: UnexpectedItem -> Internal.State -> Word -> Internal.Error
makeError :: UnexpectedItem -> State -> Word -> Error
makeError UnexpectedItem
RawItem State
st Word
cw = State -> Set ExpectItem -> Word -> Error
Internal.expectedErr State
st [] Word
cw
makeError UnexpectedItem
EmptyItem State
st Word
cw = State -> Word -> Error
Internal.emptyErr State
st Word
cw
makeError (NamedItem String
name) State
st Word
cw = State -> Set ExpectItem -> String -> CaretWidth -> Error
Internal.unexpectedErr State
st [] String
name (Word -> CaretWidth
Internal.RigidCaret Word
cw)

-- no fold, unlifed type
addReason :: Maybe String -> Internal.Error -> Internal.Error
addReason :: Maybe String -> Error -> Error
addReason Maybe String
Nothing Error
err = Error
err
addReason (Just String
reason) Error
err = String -> Error -> Error
Internal.addReason String
reason Error
err