{-# LANGUAGE Safe #-}
{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.Gigaparsec.Internal.Token.Errors (module Text.Gigaparsec.Internal.Token.Errors) where

import Text.Gigaparsec (Parsec, empty)
import Text.Gigaparsec qualified as Errors (filterS, mapMaybeS)
import Text.Gigaparsec.Char (satisfy)
import Text.Gigaparsec.Errors.Combinator qualified as Errors (
    label, explain, hide,
    filterOut, guardAgainst, mapEitherS, unexpectedWhen, unexpectedWithReasonWhen
  )
import Text.Gigaparsec.Errors.Patterns (verifiedFail, verifiedExplain)

import Data.Set (Set)
import Data.Map (Map)

import Data.Map qualified as Map (member, (!))
import Data.Kind (Constraint)
import Data.Maybe (isJust, fromJust)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty (toList)

type LabelWithExplainConfig :: *
data LabelWithExplainConfig = LENotConfigured
                            | LELabel !(Set String)
                            | LEReason !String
                            | LEHidden
                            | LELabelAndReason !(Set String) !String

type LabelConfig :: *
data LabelConfig = LNotConfigured
                 | LLabel !(Set String)
                 | LHidden

type ExplainConfig :: *
data ExplainConfig = ENotConfigured
                   | EReason !String

type Annotate :: * -> Constraint
class Annotate config where
  annotate :: config -> Parsec a -> Parsec a

instance Annotate LabelConfig where
  annotate :: forall a. LabelConfig -> Parsec a -> Parsec a
annotate LabelConfig
LNotConfigured = Parsec a -> Parsec a
forall a. a -> a
id
  annotate (LLabel Set String
ls) = Set String -> Parsec a -> Parsec a
forall a. Set String -> Parsec a -> Parsec a
Errors.label Set String
ls
  annotate LabelConfig
LHidden = Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
Errors.hide

instance Annotate ExplainConfig where
  annotate :: forall a. ExplainConfig -> Parsec a -> Parsec a
annotate ExplainConfig
ENotConfigured = Parsec a -> Parsec a
forall a. a -> a
id
  annotate (EReason String
r) = String -> Parsec a -> Parsec a
forall a. String -> Parsec a -> Parsec a
Errors.explain String
r

instance Annotate LabelWithExplainConfig where
  annotate :: forall a. LabelWithExplainConfig -> Parsec a -> Parsec a
annotate LabelWithExplainConfig
LENotConfigured = Parsec a -> Parsec a
forall a. a -> a
id
  annotate (LELabel Set String
ls) = Set String -> Parsec a -> Parsec a
forall a. Set String -> Parsec a -> Parsec a
Errors.label Set String
ls
  annotate LabelWithExplainConfig
LEHidden = Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
Errors.hide
  annotate (LEReason String
r) = String -> Parsec a -> Parsec a
forall a. String -> Parsec a -> Parsec a
Errors.explain String
r
  annotate (LELabelAndReason Set String
ls String
r) = Set String -> Parsec a -> Parsec a
forall a. Set String -> Parsec a -> Parsec a
Errors.label Set String
ls (Parsec a -> Parsec a)
-> (Parsec a -> Parsec a) -> Parsec a -> Parsec a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parsec a -> Parsec a
forall a. String -> Parsec a -> Parsec a
Errors.explain String
r

type FilterConfig :: * -> *
data FilterConfig a = VSBasicFilter
                    | VSSpecializedFilter (a -> NonEmpty String)
                    | VSUnexpected (a -> String)
                    | VSBecause (a -> String)
                    | VSUnexpectedBecause (a -> String) (a -> String)

type VanillaFilterConfig :: * -> *
data VanillaFilterConfig a = VBasicFilter
                           | VUnexpected (a -> String)
                           | VBecause (a -> String)
                           | VUnexpectedBecause (a -> String) (a -> String)

type SpecializedFilterConfig :: * -> *
data SpecializedFilterConfig a = SBasicFilter
                               | SSpecializedFilter (a -> NonEmpty String)

type Filter :: (* -> *) -> Constraint
class Filter config where
  filterS :: config a -> (a -> Bool) -> Parsec a -> Parsec a
  filterS = (a -> a) -> config a -> (a -> Bool) -> Parsec a -> Parsec a
forall a x.
(a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a
forall (config :: * -> *) a x.
Filter config =>
(a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a
filterS' a -> a
forall a. a -> a
id
  mapMaybeS :: config a -> (a -> Maybe b) -> Parsec a -> Parsec b
  mapMaybeS = (a -> a) -> config a -> (a -> Maybe b) -> Parsec a -> Parsec b
forall a x b.
(a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b
forall (config :: * -> *) a x b.
Filter config =>
(a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b
mapMaybeS' a -> a
forall a. a -> a
id

  filterS' :: (a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a
  mapMaybeS' :: (a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b

instance Filter FilterConfig where
  filterS' :: forall a x.
(a -> x) -> FilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a
filterS' a -> x
_ FilterConfig x
VSBasicFilter a -> Bool
g = (a -> Bool) -> Parsec a -> Parsec a
forall a. (a -> Bool) -> Parsec a -> Parsec a
Errors.filterS a -> Bool
g
  filterS' a -> x
f (VSSpecializedFilter x -> NonEmpty String
msgs) a -> Bool
g = (a -> Maybe [String]) -> Parsec a -> Parsec a
forall a. (a -> Maybe [String]) -> Parsec a -> Parsec a
Errors.guardAgainst ((a -> x) -> (x -> [String]) -> (a -> Bool) -> a -> Maybe [String]
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty String -> [String])
-> (x -> NonEmpty String) -> x -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> NonEmpty String
msgs) a -> Bool
g)
  filterS' a -> x
f (VSBecause x -> String
reason) a -> Bool
g = (a -> Maybe String) -> Parsec a -> Parsec a
forall a. (a -> Maybe String) -> Parsec a -> Parsec a
Errors.filterOut ((a -> x) -> (x -> String) -> (a -> Bool) -> a -> Maybe String
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f x -> String
reason a -> Bool
g)
  filterS' a -> x
f (VSUnexpected x -> String
unex) a -> Bool
g = (a -> Maybe String) -> Parsec a -> Parsec a
forall a. (a -> Maybe String) -> Parsec a -> Parsec a
Errors.unexpectedWhen ((a -> x) -> (x -> String) -> (a -> Bool) -> a -> Maybe String
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f x -> String
unex a -> Bool
g)
  filterS' a -> x
f (VSUnexpectedBecause x -> String
unex x -> String
reason) a -> Bool
g =
    (a -> Maybe (String, String)) -> Parsec a -> Parsec a
forall a. (a -> Maybe (String, String)) -> Parsec a -> Parsec a
Errors.unexpectedWithReasonWhen ((a -> x)
-> (x -> (String, String))
-> (a -> Bool)
-> a
-> Maybe (String, String)
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f (\x
x -> (x -> String
unex x
x, x -> String
reason x
x)) a -> Bool
g)

  mapMaybeS' :: forall a x b.
(a -> x)
-> FilterConfig x -> (a -> Maybe b) -> Parsec a -> Parsec b
mapMaybeS' a -> x
_ FilterConfig x
VSBasicFilter a -> Maybe b
g = (a -> Maybe b) -> Parsec a -> Parsec b
forall a b. (a -> Maybe b) -> Parsec a -> Parsec b
Errors.mapMaybeS a -> Maybe b
g
  mapMaybeS' a -> x
f (VSSpecializedFilter x -> NonEmpty String
msgs) a -> Maybe b
g = (a -> Either (NonEmpty String) b) -> Parsec a -> Parsec b
forall a b.
(a -> Either (NonEmpty String) b) -> Parsec a -> Parsec b
Errors.mapEitherS ((a -> x)
-> (x -> NonEmpty String)
-> (a -> Maybe b)
-> a
-> Either (NonEmpty String) b
forall a x e b.
(a -> x) -> (x -> e) -> (a -> Maybe b) -> a -> Either e b
errMap a -> x
f x -> NonEmpty String
msgs a -> Maybe b
g)
  mapMaybeS' a -> x
f FilterConfig x
config a -> Maybe b
g = ((a -> x) -> FilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a)
-> (a -> x)
-> FilterConfig x
-> (a -> Maybe b)
-> Parsec a
-> Parsec b
forall a x (config :: * -> *) b.
((a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a)
-> (a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b
mapMaybeSDefault (a -> x) -> FilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a
forall a x.
(a -> x) -> FilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a
forall (config :: * -> *) a x.
Filter config =>
(a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a
filterS' a -> x
f FilterConfig x
config a -> Maybe b
g

instance Filter VanillaFilterConfig where
  filterS' :: forall a x.
(a -> x)
-> VanillaFilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a
filterS' a -> x
_ VanillaFilterConfig x
VBasicFilter a -> Bool
g = (a -> Bool) -> Parsec a -> Parsec a
forall a. (a -> Bool) -> Parsec a -> Parsec a
Errors.filterS a -> Bool
g
  filterS' a -> x
f (VBecause x -> String
reason) a -> Bool
g = (a -> Maybe String) -> Parsec a -> Parsec a
forall a. (a -> Maybe String) -> Parsec a -> Parsec a
Errors.filterOut ((a -> x) -> (x -> String) -> (a -> Bool) -> a -> Maybe String
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f x -> String
reason a -> Bool
g)
  filterS' a -> x
f (VUnexpected x -> String
unex) a -> Bool
g = (a -> Maybe String) -> Parsec a -> Parsec a
forall a. (a -> Maybe String) -> Parsec a -> Parsec a
Errors.unexpectedWhen ((a -> x) -> (x -> String) -> (a -> Bool) -> a -> Maybe String
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f x -> String
unex a -> Bool
g)
  filterS' a -> x
f (VUnexpectedBecause x -> String
unex x -> String
reason) a -> Bool
g =
    (a -> Maybe (String, String)) -> Parsec a -> Parsec a
forall a. (a -> Maybe (String, String)) -> Parsec a -> Parsec a
Errors.unexpectedWithReasonWhen ((a -> x)
-> (x -> (String, String))
-> (a -> Bool)
-> a
-> Maybe (String, String)
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f (\x
x -> (x -> String
unex x
x, x -> String
reason x
x)) a -> Bool
g)

  mapMaybeS' :: forall a x b.
(a -> x)
-> VanillaFilterConfig x -> (a -> Maybe b) -> Parsec a -> Parsec b
mapMaybeS' a -> x
_ VanillaFilterConfig x
VBasicFilter a -> Maybe b
g = (a -> Maybe b) -> Parsec a -> Parsec b
forall a b. (a -> Maybe b) -> Parsec a -> Parsec b
Errors.mapMaybeS a -> Maybe b
g
  mapMaybeS' a -> x
f VanillaFilterConfig x
config a -> Maybe b
g = ((a -> x)
 -> VanillaFilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a)
-> (a -> x)
-> VanillaFilterConfig x
-> (a -> Maybe b)
-> Parsec a
-> Parsec b
forall a x (config :: * -> *) b.
((a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a)
-> (a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b
mapMaybeSDefault (a -> x)
-> VanillaFilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a
forall a x.
(a -> x)
-> VanillaFilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a
forall (config :: * -> *) a x.
Filter config =>
(a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a
filterS' a -> x
f VanillaFilterConfig x
config a -> Maybe b
g

instance Filter SpecializedFilterConfig where
  filterS' :: forall a x.
(a -> x)
-> SpecializedFilterConfig x -> (a -> Bool) -> Parsec a -> Parsec a
filterS' a -> x
_ SpecializedFilterConfig x
SBasicFilter a -> Bool
g = (a -> Bool) -> Parsec a -> Parsec a
forall a. (a -> Bool) -> Parsec a -> Parsec a
Errors.filterS a -> Bool
g
  filterS' a -> x
f (SSpecializedFilter x -> NonEmpty String
msgs) a -> Bool
g = (a -> Maybe [String]) -> Parsec a -> Parsec a
forall a. (a -> Maybe [String]) -> Parsec a -> Parsec a
Errors.guardAgainst ((a -> x) -> (x -> [String]) -> (a -> Bool) -> a -> Maybe [String]
forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty String -> [String])
-> (x -> NonEmpty String) -> x -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> NonEmpty String
msgs) a -> Bool
g)

  mapMaybeS' :: forall a x b.
(a -> x)
-> SpecializedFilterConfig x
-> (a -> Maybe b)
-> Parsec a
-> Parsec b
mapMaybeS' a -> x
_ SpecializedFilterConfig x
SBasicFilter a -> Maybe b
g = (a -> Maybe b) -> Parsec a -> Parsec b
forall a b. (a -> Maybe b) -> Parsec a -> Parsec b
Errors.mapMaybeS a -> Maybe b
g
  mapMaybeS' a -> x
f (SSpecializedFilter x -> NonEmpty String
msgs) a -> Maybe b
g = (a -> Either (NonEmpty String) b) -> Parsec a -> Parsec b
forall a b.
(a -> Either (NonEmpty String) b) -> Parsec a -> Parsec b
Errors.mapEitherS ((a -> x)
-> (x -> NonEmpty String)
-> (a -> Maybe b)
-> a
-> Either (NonEmpty String) b
forall a x e b.
(a -> x) -> (x -> e) -> (a -> Maybe b) -> a -> Either e b
errMap a -> x
f x -> NonEmpty String
msgs a -> Maybe b
g)

errWhen :: (a -> x) -> (x -> e) -> (a -> Bool) -> (a -> Maybe e)
errWhen :: forall a x e. (a -> x) -> (x -> e) -> (a -> Bool) -> a -> Maybe e
errWhen a -> x
f x -> e
g a -> Bool
p a
x
  | a -> Bool
p a
x = e -> Maybe e
forall a. a -> Maybe a
Just (x -> e
g (a -> x
f a
x))
  | Bool
otherwise = Maybe e
forall a. Maybe a
Nothing

errMap :: (a -> x) -> (x -> e) -> (a -> Maybe b) -> (a -> Either e b)
errMap :: forall a x e b.
(a -> x) -> (x -> e) -> (a -> Maybe b) -> a -> Either e b
errMap a -> x
f x -> e
g a -> Maybe b
p a
x = Either e b -> (b -> Either e b) -> Maybe b -> Either e b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e b
forall a b. a -> Either a b
Left (x -> e
g (a -> x
f a
x))) b -> Either e b
forall a b. b -> Either a b
Right (a -> Maybe b
p a
x)

mapMaybeSDefault :: ((a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a)
                 -> ((a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b)
mapMaybeSDefault :: forall a x (config :: * -> *) b.
((a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a)
-> (a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b
mapMaybeSDefault (a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a
filt a -> x
f config x
config a -> Maybe b
g = (a -> b) -> Parsec a -> Parsec b
forall a b. (a -> b) -> Parsec a -> Parsec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe b -> b) -> (a -> Maybe b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
g) (Parsec a -> Parsec b)
-> (Parsec a -> Parsec a) -> Parsec a -> Parsec b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a
filt a -> x
f config x
config (Maybe b -> Bool
forall a. Maybe a -> Bool
isJust (Maybe b -> Bool) -> (a -> Maybe b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
g)


type VerifiedBadChars :: *
data VerifiedBadChars = BadCharsFail !(Map Char (NonEmpty String))
                      | BadCharsReason !(Map Char String)
                      | BadCharsUnverified

checkBadChar :: VerifiedBadChars -> Parsec a
checkBadChar :: forall a. VerifiedBadChars -> Parsec a
checkBadChar (BadCharsFail Map Char (NonEmpty String)
cs) = (Char -> [String]) -> Parsec Char -> Parsec a
forall a b. (a -> [String]) -> Parsec a -> Parsec b
verifiedFail (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty String -> [String])
-> (Char -> NonEmpty String) -> Char -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Char (NonEmpty String)
cs Map Char (NonEmpty String) -> Char -> NonEmpty String
forall k a. Ord k => Map k a -> k -> a
Map.!)) ((Char -> Bool) -> Parsec Char
satisfy (Char -> Map Char (NonEmpty String) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Char (NonEmpty String)
cs))
checkBadChar (BadCharsReason Map Char String
cs) = (Char -> String) -> Parsec Char -> Parsec a
forall a b. (a -> String) -> Parsec a -> Parsec b
verifiedExplain (Map Char String
cs Map Char String -> Char -> String
forall k a. Ord k => Map k a -> k -> a
Map.!) ((Char -> Bool) -> Parsec Char
satisfy (Char -> Map Char String -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Char String
cs))
checkBadChar VerifiedBadChars
BadCharsUnverified = Parsec a
forall a. Parsec a
forall (f :: * -> *) a. Alternative f => f a
empty