{-# LANGUAGE OverloadedLists #-}

module Shrun.Configuration.Args.Parsing.Graph.Utils
  ( -- * High-level
    MParser,
    parseIndexSet,
    parseOneIndex,

    -- * Errors
    FatalError (..),
    runFatalErrors,
    runFatalErrors1,

    -- * Combinators
    failIfNext,
    noLabel,
    optionalTry,
    parseIfNoComma,

    -- * Low-level
    char,
    string,
    lexeme,
    parseComma,
    parseDots,

    -- * Misc
    anyLeft,
    mkMpError,
  )
where

import Data.Char qualified as Ch
import Data.Sequence.NonEmpty qualified as NESeq
import Data.Set (Set)
import Shrun.Command.Types qualified as Cmd.T
import Shrun.Command.Types.Internal (CommandIndex (MkCommandIndex))
import Shrun.Prelude
import Text.Megaparsec
  ( ErrorFancy,
    ParseError (FancyError),
    Parsec,
    ShowErrorComponent,
    (<?>),
  )
import Text.Megaparsec qualified as MP
import Text.Megaparsec.Char qualified as MPC
import Text.Megaparsec.Char.Lexer qualified as Lex
import Text.Read qualified as TR

-- | Core parser type.
type MParser a = Parsec FatalError Text a

-- | Parses an index set.
--
-- @
--   - "{1, 2, 3}"
--   - "{1 .. 3}"
--   - "{1, 4..6}"
-- @
parseIndexSet :: MParser (NESeq CommandIndex)
parseIndexSet :: MParser (NESeq CommandIndex)
parseIndexSet = do
  Char -> ParsecT FatalError Text Identity Char
char Char
'{'
  String
-> ParsecT FatalError Text Identity Char
-> ParsecT FatalError Text Identity ()
forall a.
String -> MParser a -> ParsecT FatalError Text Identity ()
failIfNext String
"Empty set" (Char -> ParsecT FatalError Text Identity Char
char Char
'}')

  NESeq CommandIndex
k <- MParser (NESeq CommandIndex)
parseElem
  [NESeq CommandIndex]
ks <- MParser (NESeq CommandIndex)
-> ParsecT FatalError Text Identity [NESeq CommandIndex]
forall a.
ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity [a]
forall (f :: Type -> Type) a. Alternative f => f a -> f [a]
many (ParsecT FatalError Text Identity ()
parseComma ParsecT FatalError Text Identity ()
-> MParser (NESeq CommandIndex) -> MParser (NESeq CommandIndex)
forall a b.
ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity b
-> ParsecT FatalError Text Identity b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> MParser (NESeq CommandIndex)
parseElem)
  Char -> ParsecT FatalError Text Identity Char
char Char
'}'
  pure (NESeq (NESeq CommandIndex) -> NESeq CommandIndex
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (NESeq (NESeq CommandIndex) -> NESeq CommandIndex)
-> NESeq (NESeq CommandIndex) -> NESeq CommandIndex
forall a b. (a -> b) -> a -> b
$ NESeq CommandIndex
k NESeq CommandIndex
-> Seq (NESeq CommandIndex) -> NESeq (NESeq CommandIndex)
forall a. a -> Seq a -> NESeq a
:<|| [NESeq CommandIndex] -> Seq (NESeq CommandIndex)
forall a. [a] -> Seq a
listToSeq [NESeq CommandIndex]
ks)
  where
    parseElem :: MParser (NESeq CommandIndex)
parseElem =
      MParser (NESeq CommandIndex)
-> MParser (NESeq CommandIndex) -> MParser (NESeq CommandIndex)
forall a. MParser a -> MParser a -> MParser a
runFatalError
        ((CommandIndex, NESeq CommandIndex) -> NESeq CommandIndex
forall a. (a, NESeq a) -> NESeq a
Cmd.T.joinRange ((CommandIndex, NESeq CommandIndex) -> NESeq CommandIndex)
-> ParsecT
     FatalError Text Identity (CommandIndex, NESeq CommandIndex)
-> MParser (NESeq CommandIndex)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT FatalError Text Identity (CommandIndex, NESeq CommandIndex)
parseRange)
        (CommandIndex -> NESeq CommandIndex
forall a. a -> NESeq a
NESeq.singleton (CommandIndex -> NESeq CommandIndex)
-> ParsecT FatalError Text Identity CommandIndex
-> MParser (NESeq CommandIndex)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT FatalError Text Identity CommandIndex
parseOneIndex)

-- | Parses a single index i.e. a positive integer.
parseOneIndex :: MParser CommandIndex
parseOneIndex :: ParsecT FatalError Text Identity CommandIndex
parseOneIndex = do
  Text
txt <- ParsecT FatalError Text Identity Text
-> ParsecT FatalError Text Identity Text
forall a. MParser a -> MParser a
lexeme (ParsecT FatalError Text Identity Text
 -> ParsecT FatalError Text Identity Text)
-> ParsecT FatalError Text Identity Text
-> ParsecT FatalError Text Identity Text
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token Text -> Bool)
-> ParsecT FatalError Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"digit") Char -> Bool
Token Text -> Bool
Ch.isDigit
  case forall a. Read a => String -> Maybe a
TR.readMaybe @Int (Text -> String
unpack Text
txt) of
    Just Int
n -> case Int -> Either String (Positive Int)
forall a.
(AMonoid a, Ord a, Show a) =>
a -> Either String (Positive a)
mkPositive Int
n of
      Right Positive Int
p -> CommandIndex -> ParsecT FatalError Text Identity CommandIndex
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (CommandIndex -> ParsecT FatalError Text Identity CommandIndex)
-> CommandIndex -> ParsecT FatalError Text Identity CommandIndex
forall a b. (a -> b) -> a -> b
$ Positive Int -> CommandIndex
MkCommandIndex Positive Int
p
      Left String
err -> String -> ParsecT FatalError Text Identity CommandIndex
forall a. String -> ParsecT FatalError Text Identity a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err
    Maybe Int
Nothing ->
      String -> ParsecT FatalError Text Identity CommandIndex
forall a. String -> ParsecT FatalError Text Identity a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
        (String -> ParsecT FatalError Text Identity CommandIndex)
-> String -> ParsecT FatalError Text Identity CommandIndex
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
Item [String]
"Failed parsing nat: ",
            Text -> String
unpack Text
txt
          ]

-- | Parse "1..3".
parseRange :: MParser (Tuple2 CommandIndex (NESeq CommandIndex))
parseRange :: ParsecT FatalError Text Identity (CommandIndex, NESeq CommandIndex)
parseRange = do
  CommandIndex
l <- ParsecT FatalError Text Identity CommandIndex
parseOneIndex
  ParsecT FatalError Text Identity ()
parseDots
  CommandIndex
u <- ParsecT FatalError Text Identity CommandIndex
parseOneIndex

  case CommandIndex
-> CommandIndex -> Either String (CommandIndex, NESeq CommandIndex)
Cmd.T.range CommandIndex
l CommandIndex
u of
    Right (CommandIndex, NESeq CommandIndex)
r -> (CommandIndex, NESeq CommandIndex)
-> ParsecT
     FatalError Text Identity (CommandIndex, NESeq CommandIndex)
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (CommandIndex, NESeq CommandIndex)
r
    Left String
err -> FatalError
-> ParsecT
     FatalError Text Identity (CommandIndex, NESeq CommandIndex)
forall e s (m :: Type -> Type) a. MonadParsec e s m => e -> m a
MP.customFailure (String -> FatalError
MkFatalError String
err)

-- | Returns true iff eof is not succesfully parsed.
anyLeft :: MParser Bool
anyLeft :: MParser Bool
anyLeft = do
  ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity (Maybe ())
forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
MP.optional ParsecT FatalError Text Identity ()
forall e s (m :: Type -> Type). MonadParsec e s m => m ()
MP.eof ParsecT FatalError Text Identity (Maybe ())
-> (Maybe () -> Bool) -> MParser Bool
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Maybe ()
Nothing -> Bool
True
    Just () -> Bool
False

-- | Runs the parser if iff a comma is /not/ encountered. If a comma is
-- encountered, it is not consumed, and the default value is returned.
parseIfNoComma :: a -> MParser a -> MParser a
parseIfNoComma :: forall a. a -> MParser a -> MParser a
parseIfNoComma a
def MParser a
p = ParsecT FatalError Text Identity ()
-> MParser a -> MParser a -> MParser a
forall p a. MParser p -> MParser a -> MParser a -> MParser a
lookAheadBranch ParsecT FatalError Text Identity ()
parseComma MParser a
p (a -> MParser a
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
def)

-- | Fails with the given error message if the given parser is next. Does not
-- consume the parser, for better carets in the error message.
failIfNext :: String -> MParser a -> MParser ()
failIfNext :: forall a.
String -> MParser a -> ParsecT FatalError Text Identity ()
failIfNext String
err MParser a
p = MParser a
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
forall p a. MParser p -> MParser a -> MParser a -> MParser a
lookAheadBranch MParser a
p (() -> ParsecT FatalError Text Identity ()
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()) (String -> ParsecT FatalError Text Identity ()
forall a. String -> ParsecT FatalError Text Identity a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err)

-- | @lookAheadBranch ptest p1 p2@ tries ptest without consuming it. If it
-- fails, runs p1. Otherwise runs p2.
--
-- Note if ptest fails, it may consume input. Consider try if this is a
-- problem.
lookAheadBranch :: MParser p -> MParser a -> MParser a -> MParser a
lookAheadBranch :: forall p a. MParser p -> MParser a -> MParser a -> MParser a
lookAheadBranch MParser p
ptest MParser a
p1 MParser a
p2 =
  -- Clear label as we do not want it to interfere with error
  -- messages.
  MParser p -> ParsecT FatalError Text Identity (Maybe p)
forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
MP.optional (MParser p -> MParser p
forall a. MParser a -> MParser a
noLabel (MParser p -> MParser p) -> MParser p -> MParser p
forall a b. (a -> b) -> a -> b
$ MParser p -> MParser p
forall a. MParser a -> MParser a
forall e s (m :: Type -> Type) a. MonadParsec e s m => m a -> m a
MP.lookAhead MParser p
ptest) ParsecT FatalError Text Identity (Maybe p)
-> (Maybe p -> MParser a) -> MParser a
forall a b.
ParsecT FatalError Text Identity a
-> (a -> ParsecT FatalError Text Identity b)
-> ParsecT FatalError Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe p
Nothing -> MParser a
p1
    Just p
_ -> MParser a
p2

-- | Parses a comma.
parseComma :: MParser ()
parseComma :: ParsecT FatalError Text Identity ()
parseComma = Char -> ParsecT FatalError Text Identity Char
char Char
',' ParsecT FatalError Text Identity Char
-> () -> ParsecT FatalError Text Identity ()
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> ()

-- | Parses two dots.
parseDots :: MParser ()
parseDots :: ParsecT FatalError Text Identity ()
parseDots = Text -> ParsecT FatalError Text Identity Text
string Text
".." ParsecT FatalError Text Identity Text
-> () -> ParsecT FatalError Text Identity ()
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> () ParsecT FatalError Text Identity ()
-> String -> ParsecT FatalError Text Identity ()
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"range ('..')"

-- | Clears a parser label.
noLabel :: MParser a -> MParser a
noLabel :: forall a. MParser a -> MParser a
noLabel = String
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall a.
String
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
""

-- | Optional + try i.e. returns Just iff the parser succeeds, otherwise
-- backtracks.
optionalTry :: MParser a -> MParser (Maybe a)
optionalTry :: forall a. MParser a -> MParser (Maybe a)
optionalTry = MParser a -> MParser (Maybe a)
forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
MP.optional (MParser a -> MParser (Maybe a))
-> (MParser a -> MParser a) -> MParser a -> MParser (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MParser a -> MParser a
forall a. MParser a -> MParser a
forall e s (m :: Type -> Type) a. MonadParsec e s m => m a -> m a
MP.try

-- | Modifies a parser to consume trailing whitespace.
lexeme :: MParser a -> MParser a
lexeme :: forall a. MParser a -> MParser a
lexeme = ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
m () -> m a -> m a
Lex.lexeme ParsecT FatalError Text Identity ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MPC.space

-- | Consumes char and trailing whitespace.
char :: Char -> MParser Char
char :: Char -> ParsecT FatalError Text Identity Char
char = ParsecT FatalError Text Identity Char
-> ParsecT FatalError Text Identity Char
forall a. MParser a -> MParser a
lexeme (ParsecT FatalError Text Identity Char
 -> ParsecT FatalError Text Identity Char)
-> (Char -> ParsecT FatalError Text Identity Char)
-> Char
-> ParsecT FatalError Text Identity Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> ParsecT FatalError Text Identity Char
Token Text -> ParsecT FatalError Text Identity (Token Text)
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
MPC.char

-- | Consumes string and trailing whitespace.
string :: Text -> MParser Text
string :: Text -> ParsecT FatalError Text Identity Text
string = ParsecT FatalError Text Identity Text
-> ParsecT FatalError Text Identity Text
forall a. MParser a -> MParser a
lexeme (ParsecT FatalError Text Identity Text
 -> ParsecT FatalError Text Identity Text)
-> (Text -> ParsecT FatalError Text Identity Text)
-> Text
-> ParsecT FatalError Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ParsecT FatalError Text Identity Text
Tokens Text -> ParsecT FatalError Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string

-- | Represents a "fatal" parse error i.e. we should not try any other parsers.
-- This exists for better error messages.
--
-- Suppose we try parsers p1 and p2 on some text. If p1 fails, normally we will
-- try p2, and if /that/ fails, use its error message. However, it may be the
-- case that p1 has the "real" failure, and its error message would be
-- better.
--
-- For example, when parsing nodes, we attempt to parse, in order:
--
--   - Sets: @"{2,3}"@
--   - Arrow ranges: @"2..3"@
--   - Positive integers: @"3"@
--
-- Suppose we parse '{3..2}'. This is a set, but the set parser will fail due
-- to a bad range error. Normally, we will then try arrow ranges and positive
-- integers, which will both fail, and the positive integer error will be
-- reported. This is misleading though, as the real problem was deep in the
-- set parser i.e. the range.
--
-- Hence we report this as a "fatal error", and have special logic that only
-- tries other parsers when no fatal errors have been encountered.
newtype FatalError = MkFatalError String
  deriving stock (FatalError -> FatalError -> Bool
(FatalError -> FatalError -> Bool)
-> (FatalError -> FatalError -> Bool) -> Eq FatalError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FatalError -> FatalError -> Bool
== :: FatalError -> FatalError -> Bool
$c/= :: FatalError -> FatalError -> Bool
/= :: FatalError -> FatalError -> Bool
Eq, Eq FatalError
Eq FatalError =>
(FatalError -> FatalError -> Ordering)
-> (FatalError -> FatalError -> Bool)
-> (FatalError -> FatalError -> Bool)
-> (FatalError -> FatalError -> Bool)
-> (FatalError -> FatalError -> Bool)
-> (FatalError -> FatalError -> FatalError)
-> (FatalError -> FatalError -> FatalError)
-> Ord FatalError
FatalError -> FatalError -> Bool
FatalError -> FatalError -> Ordering
FatalError -> FatalError -> FatalError
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
$ccompare :: FatalError -> FatalError -> Ordering
compare :: FatalError -> FatalError -> Ordering
$c< :: FatalError -> FatalError -> Bool
< :: FatalError -> FatalError -> Bool
$c<= :: FatalError -> FatalError -> Bool
<= :: FatalError -> FatalError -> Bool
$c> :: FatalError -> FatalError -> Bool
> :: FatalError -> FatalError -> Bool
$c>= :: FatalError -> FatalError -> Bool
>= :: FatalError -> FatalError -> Bool
$cmax :: FatalError -> FatalError -> FatalError
max :: FatalError -> FatalError -> FatalError
$cmin :: FatalError -> FatalError -> FatalError
min :: FatalError -> FatalError -> FatalError
Ord, Int -> FatalError -> String -> String
[FatalError] -> String -> String
FatalError -> String
(Int -> FatalError -> String -> String)
-> (FatalError -> String)
-> ([FatalError] -> String -> String)
-> Show FatalError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FatalError -> String -> String
showsPrec :: Int -> FatalError -> String -> String
$cshow :: FatalError -> String
show :: FatalError -> String
$cshowList :: [FatalError] -> String -> String
showList :: [FatalError] -> String -> String
Show)

instance ShowErrorComponent FatalError where
  showErrorComponent :: FatalError -> String
showErrorComponent (MkFatalError String
s) = String
s

-- | Like 'asum', except the combinator is 'runFatalError'. The first
-- parser is the default when all fail, intended for a better error message.
runFatalErrors :: MParser a -> List (MParser a) -> MParser a
runFatalErrors :: forall a. MParser a -> [MParser a] -> MParser a
runFatalErrors = (MParser a -> MParser a -> MParser a)
-> MParser a -> [MParser a] -> MParser a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr MParser a -> MParser a -> MParser a
forall a. MParser a -> MParser a -> MParser a
runFatalError

-- | Like 'runFatalErrors' but with no default error. For when we want the
-- underlying error to be used.
runFatalErrors1 :: NonEmpty (MParser a) -> MParser a
runFatalErrors1 :: forall a. NonEmpty (MParser a) -> MParser a
runFatalErrors1 = (MParser a -> MParser a -> MParser a)
-> NonEmpty (MParser a) -> MParser a
forall (t :: Type -> Type) a.
Foldable1 t =>
(a -> a -> a) -> t a -> a
foldr1 MParser a -> MParser a -> MParser a
forall a. MParser a -> MParser a -> MParser a
runFatalError

-- | Like '(<|>)', except it does not try the RHS when the LHS has a fatal
-- error.
runFatalError :: MParser a -> MParser a -> MParser a
runFatalError :: forall a. MParser a -> MParser a -> MParser a
runFatalError MParser a
p1 MParser a
p2 =
  MParser a
-> ParsecT
     FatalError Text Identity (Either (ParseError Text FatalError) a)
forall a.
ParsecT FatalError Text Identity a
-> ParsecT
     FatalError Text Identity (Either (ParseError Text FatalError) a)
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
m a -> m (Either (ParseError s e) a)
MP.observing (MParser a -> MParser a
forall a. MParser a -> MParser a
forall e s (m :: Type -> Type) a. MonadParsec e s m => m a -> m a
MP.try MParser a
p1) ParsecT
  FatalError Text Identity (Either (ParseError Text FatalError) a)
-> (Either (ParseError Text FatalError) a -> MParser a)
-> MParser a
forall a b.
ParsecT FatalError Text Identity a
-> (a -> ParsecT FatalError Text Identity b)
-> ParsecT FatalError Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
x -> a -> MParser a
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
x
    Left ParseError Text FatalError
err -> case ParseError Text FatalError -> Maybe (Set (ErrorFancy FatalError))
forall s.
ParseError s FatalError -> Maybe (Set (ErrorFancy FatalError))
hasFatalError ParseError Text FatalError
err of
      Just Set (ErrorFancy FatalError)
errSet -> Set (ErrorFancy FatalError) -> MParser a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
Set (ErrorFancy e) -> m a
MP.fancyFailure Set (ErrorFancy FatalError)
errSet
      Maybe (Set (ErrorFancy FatalError))
Nothing -> MParser a
p2

hasFatalError :: ParseError s FatalError -> Maybe (Set (ErrorFancy FatalError))
hasFatalError :: forall s.
ParseError s FatalError -> Maybe (Set (ErrorFancy FatalError))
hasFatalError = \case
  FancyError Int
_ Set (ErrorFancy FatalError)
errSet ->
    -- NOTE: We can improve this from a linear search to O(log n) by making
    -- FatalError's Eq trivial (always True), and doing a lookup for
    -- 'MkFatalError ""'. This function would then return Bool instead of
    -- the error, and 'runFatalError' would return 'p1' instead of
    -- restoring the error (unnecessary regardless).
    --
    -- This has a slight change on the test output e.g. the error
    --
    --    option --edges: 1:6:
    --      |
    --    1 | 1 & 3..2
    --      |      ^
    --   Bad range. Expected 3 <= 2
    --
    -- Becomes
    --
    --    option --edges: 1:10:
    --      |
    --    1 | 1 & 3..2
    --      |          ^
    --   Bad range. Expected 3 <= 2
    --
    -- i.e. the caret indicates that the range was consumed. This is
    -- probably what we want anyway, though we put it off for now as this
    -- "optimization" is likely useless (errSet has max size 1, anyway),
    -- and reducing Eq/Ord may be undesirable for other reasons.
    if (ErrorFancy FatalError -> Bool)
-> Set (ErrorFancy FatalError) -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any ErrorFancy FatalError -> Bool
forall {e}. ErrorFancy e -> Bool
k Set (ErrorFancy FatalError)
errSet
      then Set (ErrorFancy FatalError) -> Maybe (Set (ErrorFancy FatalError))
forall a. a -> Maybe a
Just Set (ErrorFancy FatalError)
errSet
      else Maybe (Set (ErrorFancy FatalError))
forall a. Maybe a
Nothing
  ParseError s FatalError
_ -> Maybe (Set (ErrorFancy FatalError))
forall a. Maybe a
Nothing
  where
    k :: ErrorFancy e -> Bool
k = \case
      MP.ErrorCustom e
_ -> Bool
True
      ErrorFancy e
_ -> Bool
False

mkMpError :: String -> String -> String
mkMpError :: String -> String -> String
mkMpError String
u String
e =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
Item [String]
"unexpected ",
      String
Item [String]
u,
      String
Item [String]
"\nexpecting ",
      String
Item [String]
e
    ]