module HeadedMegaparsec
  ( -- * Types
    HeadedParsec,

    -- * Execution
    toParsec,

    -- * Transformation
    wrapToHead,
    label,
    hidden,
    dbg,
    filter,

    -- * Construction
    parse,
    endHead,
  )
where

import Control.Applicative.Combinators
import qualified HeadedMegaparsec.Megaparsec as Megaparsec
import HeadedMegaparsec.Prelude hiding (filter, head, tail, try)
import Text.Megaparsec (Parsec, Stream)
import qualified Text.Megaparsec as Megaparsec
import qualified Text.Megaparsec.Char as MegaparsecChar
import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer
import qualified Text.Megaparsec.Debug as Megaparsec

-- $setup
--
-- >>> :set -XApplicativeDo

-- * Types

-- |
-- Headed parser.
--
-- Abstracts over explicit composition between consecutive megaparsec `try` blocks,
-- providing for better error messages.
--
-- With headed parser you don't need to use `try` at all.
--
-- ==__Examples__
--
-- >>> import Prelude
-- >>> import Control.Applicative
-- >>> import Data.Void
-- >>> import qualified Text.Megaparsec as M
-- >>> import qualified Text.Megaparsec.Char as M
-- >>> import qualified Text.Megaparsec.Char.Lexer as ML
-- >>> :{
--   let
--     select :: HeadedParsec Void String (Maybe [Either Char Int], Maybe Int)
--     select = do
--       string' "select"
--       endHead
--       _targets <- optional (space1 *> targets)
--       _limit <- optional (space1 *> limit)
--       return (_targets, _limit)
--       where
--         -- Lifted versions of basic parsers:
--         char = parse . M.char
--         space = parse M.space
--         space1 = parse M.space1
--         decimal = parse ML.decimal
--         string' = parse . M.string'
--         -- Syntax parsers:
--         targets = M.sepBy1 target commaSeparator
--         target = Left <$> char '*' <|> Right <$> decimal
--         commaSeparator = space *> char ',' *> endHead *> space
--         limit = string' "limit" *> endHead *> space1 *> decimal
--     test :: String -> IO ()
--     test = M.parseTest (toParsec select <* M.eof)
-- :}
--
-- >>> test "select 1, "
-- 1:11:
--   |
-- 1 | select 1,
--   |           ^
-- unexpected end of input
-- expecting '*', integer, or white space
--
-- >>> test "select limit "
-- ...
-- unexpected end of input
-- expecting integer or white space
--
-- >>> test "select 1, 2 limit 2"
-- (Just [Right 1,Right 2],Just 2)
newtype HeadedParsec err strm a = HeadedParsec (Parsec err strm (Either a (Parsec err strm a)))

-- |
-- A helper required for hacking `dbg`.
data Showable a = Showable String a

-- * Instances

-- ** Showable

instance Show (Showable a) where
  show :: Showable a -> String
show (Showable String
msg a
_) = String
msg

-- ** HeadedParsec

instance Functor (HeadedParsec err strm) where
  fmap :: (a -> b) -> HeadedParsec err strm a -> HeadedParsec err strm b
fmap a -> b
fn (HeadedParsec Parsec err strm (Either a (Parsec err strm a))
p) = Parsec err strm (Either b (Parsec err strm b))
-> HeadedParsec err strm b
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec ((Either a (Parsec err strm a) -> Either b (Parsec err strm b))
-> Parsec err strm (Either a (Parsec err strm a))
-> Parsec err strm (Either b (Parsec err strm b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b)
-> (Parsec err strm a -> Parsec err strm b)
-> Either a (Parsec err strm a)
-> Either b (Parsec err strm b)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
fn ((a -> b) -> Parsec err strm a -> Parsec err strm b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
fn)) Parsec err strm (Either a (Parsec err strm a))
p)

instance (Ord err, Stream strm) => Applicative (HeadedParsec err strm) where
  pure :: a -> HeadedParsec err strm a
pure = Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either a (Parsec err strm a))
 -> HeadedParsec err strm a)
-> (a -> Parsec err strm (Either a (Parsec err strm a)))
-> a
-> HeadedParsec err strm a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (Parsec err strm a)
 -> Parsec err strm (Either a (Parsec err strm a)))
-> (a -> Either a (Parsec err strm a))
-> a
-> Parsec err strm (Either a (Parsec err strm a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Either a (Parsec err strm a)
forall a b. a -> Either a b
Left
  <*> :: HeadedParsec err strm (a -> b)
-> HeadedParsec err strm a -> HeadedParsec err strm b
(<*>) (HeadedParsec Parsec err strm (Either (a -> b) (Parsec err strm (a -> b)))
p1) (HeadedParsec Parsec err strm (Either a (Parsec err strm a))
p2) = Parsec err strm (Either b (Parsec err strm b))
-> HeadedParsec err strm b
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either b (Parsec err strm b))
 -> HeadedParsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
-> HeadedParsec err strm b
forall a b. (a -> b) -> a -> b
$ do
    Either (a -> b) (Parsec err strm (a -> b))
junction1 <- Parsec err strm (Either (a -> b) (Parsec err strm (a -> b)))
p1
    case Either (a -> b) (Parsec err strm (a -> b))
junction1 of
      Left a -> b
aToB -> do
        Either a (Parsec err strm a)
junction2 <- Parsec err strm (Either a (Parsec err strm a))
p2
        case Either a (Parsec err strm a)
junction2 of
          Left a
a -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either b (Parsec err strm b)
forall a b. a -> Either a b
Left (a -> b
aToB a
a))
          Right Parsec err strm a
tailP2 -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either b (Parsec err strm b)
 -> Parsec err strm (Either b (Parsec err strm b)))
-> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall a b. (a -> b) -> a -> b
$
            Parsec err strm b -> Either b (Parsec err strm b)
forall a b. b -> Either a b
Right (Parsec err strm b -> Either b (Parsec err strm b))
-> Parsec err strm b -> Either b (Parsec err strm b)
forall a b. (a -> b) -> a -> b
$ do
              a
a <- Parsec err strm a
tailP2
              return (a -> b
aToB a
a)
      Right Parsec err strm (a -> b)
tailP1 -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either b (Parsec err strm b)
 -> Parsec err strm (Either b (Parsec err strm b)))
-> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall a b. (a -> b) -> a -> b
$
        Parsec err strm b -> Either b (Parsec err strm b)
forall a b. b -> Either a b
Right (Parsec err strm b -> Either b (Parsec err strm b))
-> Parsec err strm b -> Either b (Parsec err strm b)
forall a b. (a -> b) -> a -> b
$ do
          a -> b
aToB <- Parsec err strm (a -> b)
tailP1
          Either a (Parsec err strm a)
junction2 <- Parsec err strm (Either a (Parsec err strm a))
p2
          case Either a (Parsec err strm a)
junction2 of
            Left a
a -> b -> Parsec err strm b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
aToB a
a)
            Right Parsec err strm a
tailP2 -> do
              a
a <- Parsec err strm a
tailP2
              return (a -> b
aToB a
a)

instance (Ord err, Stream strm) => Selective (HeadedParsec err strm) where
  select :: HeadedParsec err strm (Either a b)
-> HeadedParsec err strm (a -> b) -> HeadedParsec err strm b
select (HeadedParsec Parsec
  err strm (Either (Either a b) (Parsec err strm (Either a b)))
p1) (HeadedParsec Parsec err strm (Either (a -> b) (Parsec err strm (a -> b)))
p2) = Parsec err strm (Either b (Parsec err strm b))
-> HeadedParsec err strm b
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either b (Parsec err strm b))
 -> HeadedParsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
-> HeadedParsec err strm b
forall a b. (a -> b) -> a -> b
$ do
    Either (Either a b) (Parsec err strm (Either a b))
junction1 <- Parsec
  err strm (Either (Either a b) (Parsec err strm (Either a b)))
p1
    case Either (Either a b) (Parsec err strm (Either a b))
junction1 of
      Left Either a b
eitherAOrB -> case Either a b
eitherAOrB of
        Right b
b -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either b (Parsec err strm b)
forall a b. a -> Either a b
Left b
b)
        Left a
a -> do
          Either (a -> b) (Parsec err strm (a -> b))
junction2 <- Parsec err strm (Either (a -> b) (Parsec err strm (a -> b)))
p2
          case Either (a -> b) (Parsec err strm (a -> b))
junction2 of
            Left a -> b
aToB -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either b (Parsec err strm b)
forall a b. a -> Either a b
Left (a -> b
aToB a
a))
            Right Parsec err strm (a -> b)
tailP2 -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Parsec err strm b -> Either b (Parsec err strm b)
forall a b. b -> Either a b
Right (((a -> b) -> b) -> Parsec err strm (a -> b) -> Parsec err strm b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) Parsec err strm (a -> b)
tailP2))
      Right Parsec err strm (Either a b)
tailP1 -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either b (Parsec err strm b)
 -> Parsec err strm (Either b (Parsec err strm b)))
-> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall a b. (a -> b) -> a -> b
$
        Parsec err strm b -> Either b (Parsec err strm b)
forall a b. b -> Either a b
Right (Parsec err strm b -> Either b (Parsec err strm b))
-> Parsec err strm b -> Either b (Parsec err strm b)
forall a b. (a -> b) -> a -> b
$ do
          Either a b
eitherAOrB <- Parsec err strm (Either a b)
tailP1
          case Either a b
eitherAOrB of
            Right b
b -> b -> Parsec err strm b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
            Left a
a -> do
              Either (a -> b) (Parsec err strm (a -> b))
junction2 <- Parsec err strm (Either (a -> b) (Parsec err strm (a -> b)))
p2
              case Either (a -> b) (Parsec err strm (a -> b))
junction2 of
                Left a -> b
aToB -> b -> Parsec err strm b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
aToB a
a)
                Right Parsec err strm (a -> b)
tailP2 -> ((a -> b) -> b) -> Parsec err strm (a -> b) -> Parsec err strm b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) Parsec err strm (a -> b)
tailP2

instance (Ord err, Stream strm) => Monad (HeadedParsec err strm) where
  return :: a -> HeadedParsec err strm a
return = a -> HeadedParsec err strm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: HeadedParsec err strm a
-> (a -> HeadedParsec err strm b) -> HeadedParsec err strm b
(>>=) (HeadedParsec Parsec err strm (Either a (Parsec err strm a))
p1) a -> HeadedParsec err strm b
k2 = Parsec err strm (Either b (Parsec err strm b))
-> HeadedParsec err strm b
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either b (Parsec err strm b))
 -> HeadedParsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
-> HeadedParsec err strm b
forall a b. (a -> b) -> a -> b
$ do
    Either a (Parsec err strm a)
junction1 <- Parsec err strm (Either a (Parsec err strm a))
p1
    case Either a (Parsec err strm a)
junction1 of
      Left a
a -> case a -> HeadedParsec err strm b
k2 a
a of HeadedParsec Parsec err strm (Either b (Parsec err strm b))
p2 -> Parsec err strm (Either b (Parsec err strm b))
p2
      Right Parsec err strm a
tailP1 -> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either b (Parsec err strm b)
 -> Parsec err strm (Either b (Parsec err strm b)))
-> Either b (Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
forall a b. (a -> b) -> a -> b
$
        Parsec err strm b -> Either b (Parsec err strm b)
forall a b. b -> Either a b
Right (Parsec err strm b -> Either b (Parsec err strm b))
-> Parsec err strm b -> Either b (Parsec err strm b)
forall a b. (a -> b) -> a -> b
$ do
          a
a <- Parsec err strm a
tailP1
          Parsec err strm (Either b (Parsec err strm b)) -> Parsec err strm b
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm (Either a (Parsec err strm a)) -> Parsec err strm a
Megaparsec.contPossibly (Parsec err strm (Either b (Parsec err strm b))
 -> Parsec err strm b)
-> Parsec err strm (Either b (Parsec err strm b))
-> Parsec err strm b
forall a b. (a -> b) -> a -> b
$ case a -> HeadedParsec err strm b
k2 a
a of HeadedParsec Parsec err strm (Either b (Parsec err strm b))
p2 -> Parsec err strm (Either b (Parsec err strm b))
p2

-- |
-- Alternation is performed only the basis of heads.
-- Bodies do not participate.
instance (Ord err, Stream strm) => Alternative (HeadedParsec err strm) where
  empty :: HeadedParsec err strm a
empty = Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec Parsec err strm (Either a (Parsec err strm a))
forall (f :: * -> *) a. Alternative f => f a
empty
  <|> :: HeadedParsec err strm a
-> HeadedParsec err strm a -> HeadedParsec err strm a
(<|>) (HeadedParsec Parsec err strm (Either a (Parsec err strm a))
p1) (HeadedParsec Parsec err strm (Either a (Parsec err strm a))
p2) = Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either a (Parsec err strm a))
-> Parsec err strm (Either a (Parsec err strm a))
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try Parsec err strm (Either a (Parsec err strm a))
p1 Parsec err strm (Either a (Parsec err strm a))
-> Parsec err strm (Either a (Parsec err strm a))
-> Parsec err strm (Either a (Parsec err strm a))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec err strm (Either a (Parsec err strm a))
p2)

-- |
-- Alternation is performed only the basis of heads.
-- Bodies do not participate.
instance (Ord err, Stream strm) => MonadPlus (HeadedParsec err strm) where
  mzero :: HeadedParsec err strm a
mzero = HeadedParsec err strm a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: HeadedParsec err strm a
-> HeadedParsec err strm a -> HeadedParsec err strm a
mplus = HeadedParsec err strm a
-> HeadedParsec err strm a -> HeadedParsec err strm a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance (Ord err, Stream strm) => MonadFail (HeadedParsec err strm) where
  fail :: String -> HeadedParsec err strm a
fail = Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either a (Parsec err strm a))
 -> HeadedParsec err strm a)
-> (String -> Parsec err strm (Either a (Parsec err strm a)))
-> String
-> HeadedParsec err strm a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Parsec err strm (Either a (Parsec err strm a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

-- * Execution

-- |
-- Convert headed parser into megaparsec parser.
toParsec :: (Ord err, Stream strm) => HeadedParsec err strm a -> Parsec err strm a
toParsec :: HeadedParsec err strm a -> Parsec err strm a
toParsec (HeadedParsec Parsec err strm (Either a (Parsec err strm a))
p) = Parsec err strm (Either a (Parsec err strm a)) -> Parsec err strm a
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm (Either a (Parsec err strm a)) -> Parsec err strm a
Megaparsec.contPossibly Parsec err strm (Either a (Parsec err strm a))
p

-- * Helpers

mapParsec :: (Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1)) -> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2))) -> HeadedParsec err1 strm1 res1 -> HeadedParsec err2 strm2 res2
mapParsec :: (Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
 -> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2)))
-> HeadedParsec err1 strm1 res1 -> HeadedParsec err2 strm2 res2
mapParsec Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
-> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2))
fn (HeadedParsec Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
p) = Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2))
-> HeadedParsec err2 strm2 res2
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
-> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2))
fn Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
p)

-- * Transformation

-- |
-- Wrap a parser to be usable as a whole in a head block,
-- allowing it in effect to be composed with the following parsers into a single `try` when executed,
-- no matter whether it contains `endHead` or not.
wrapToHead :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm a
wrapToHead :: HeadedParsec err strm a -> HeadedParsec err strm a
wrapToHead = (Parsec err strm (Either a (Parsec err strm a))
 -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a -> HeadedParsec err strm a
forall err1 strm1 res1 err2 strm2 res2.
(Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
 -> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2)))
-> HeadedParsec err1 strm1 res1 -> HeadedParsec err2 strm2 res2
mapParsec ((Parsec err strm (Either a (Parsec err strm a))
  -> Parsec err strm (Either a (Parsec err strm a)))
 -> HeadedParsec err strm a -> HeadedParsec err strm a)
-> (Parsec err strm (Either a (Parsec err strm a))
    -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a
-> HeadedParsec err strm a
forall a b. (a -> b) -> a -> b
$ (a -> Either a (Parsec err strm a))
-> Parsec err strm a
-> Parsec err strm (Either a (Parsec err strm a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a (Parsec err strm a)
forall a b. a -> Either a b
Left (Parsec err strm a
 -> Parsec err strm (Either a (Parsec err strm a)))
-> (Parsec err strm (Either a (Parsec err strm a))
    -> Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
-> Parsec err strm (Either a (Parsec err strm a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsec err strm (Either a (Parsec err strm a)) -> Parsec err strm a
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm (Either a (Parsec err strm a)) -> Parsec err strm a
Megaparsec.contPossibly

-- |
-- Label a headed parser.
-- Works the same way as megaparsec's `Megaparsec.label`.
label :: (Ord err, Stream strm) => String -> HeadedParsec err strm a -> HeadedParsec err strm a
label :: String -> HeadedParsec err strm a -> HeadedParsec err strm a
label String
label = (Parsec err strm (Either a (Parsec err strm a))
 -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a -> HeadedParsec err strm a
forall err1 strm1 res1 err2 strm2 res2.
(Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
 -> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2)))
-> HeadedParsec err1 strm1 res1 -> HeadedParsec err2 strm2 res2
mapParsec (String
-> Parsec err strm (Either a (Parsec err strm a))
-> Parsec err strm (Either a (Parsec err strm a))
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
Megaparsec.label String
label)

-- |
-- Adaptation of 'Megaparsec.hidden'.
hidden :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm a
hidden :: HeadedParsec err strm a -> HeadedParsec err strm a
hidden = (Parsec err strm (Either a (Parsec err strm a))
 -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a -> HeadedParsec err strm a
forall err1 strm1 res1 err2 strm2 res2.
(Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
 -> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2)))
-> HeadedParsec err1 strm1 res1 -> HeadedParsec err2 strm2 res2
mapParsec Parsec err strm (Either a (Parsec err strm a))
-> Parsec err strm (Either a (Parsec err strm a))
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.hidden

-- |
-- Make a parser print debugging information when evaluated.
-- The first parameter is a custom label.
--
-- This function is a wrapper around `Megaparsec.dbg`.
-- It generates two debugging entries: one for head and one for tail.
dbg :: (Ord err, Megaparsec.ShowErrorComponent err, Megaparsec.VisualStream strm, Show a) => String -> HeadedParsec err strm a -> HeadedParsec err strm a
dbg :: String -> HeadedParsec err strm a -> HeadedParsec err strm a
dbg String
label = (Parsec err strm (Either a (Parsec err strm a))
 -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a -> HeadedParsec err strm a
forall err1 strm1 res1 err2 strm2 res2.
(Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
 -> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2)))
-> HeadedParsec err1 strm1 res1 -> HeadedParsec err2 strm2 res2
mapParsec ((Parsec err strm (Either a (Parsec err strm a))
  -> Parsec err strm (Either a (Parsec err strm a)))
 -> HeadedParsec err strm a -> HeadedParsec err strm a)
-> (Parsec err strm (Either a (Parsec err strm a))
    -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a
-> HeadedParsec err strm a
forall a b. (a -> b) -> a -> b
$ \Parsec err strm (Either a (Parsec err strm a))
p -> do
  Showable String
_ Either a (Parsec err strm a)
junction <- String
-> ParsecT
     err strm Identity (Showable (Either a (Parsec err strm a)))
-> ParsecT
     err strm Identity (Showable (Either a (Parsec err strm a)))
forall e s (m :: * -> *) a.
(VisualStream s, ShowErrorComponent e, Show a) =>
String -> ParsecT e s m a -> ParsecT e s m a
Megaparsec.dbg (String
label String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/head") ((Either a (Parsec err strm a)
 -> Showable (Either a (Parsec err strm a)))
-> Parsec err strm (Either a (Parsec err strm a))
-> ParsecT
     err strm Identity (Showable (Either a (Parsec err strm a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Showable (Either a (Parsec err strm a)))
-> (Parsec err strm a -> Showable (Either a (Parsec err strm a)))
-> Either a (Parsec err strm a)
-> Showable (Either a (Parsec err strm a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\a
a -> String
-> Either a (Parsec err strm a)
-> Showable (Either a (Parsec err strm a))
forall a. String -> a -> Showable a
Showable (a -> String
forall a. Show a => a -> String
show a
a) (a -> Either a (Parsec err strm a)
forall a b. a -> Either a b
Left a
a)) (String
-> Either a (Parsec err strm a)
-> Showable (Either a (Parsec err strm a))
forall a. String -> a -> Showable a
Showable String
"<tail parser>" (Either a (Parsec err strm a)
 -> Showable (Either a (Parsec err strm a)))
-> (Parsec err strm a -> Either a (Parsec err strm a))
-> Parsec err strm a
-> Showable (Either a (Parsec err strm a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsec err strm a -> Either a (Parsec err strm a)
forall a b. b -> Either a b
Right)) Parsec err strm (Either a (Parsec err strm a))
p)
  case Either a (Parsec err strm a)
junction of
    Left a
a -> Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a (Parsec err strm a)
forall a b. a -> Either a b
Left a
a)
    Right Parsec err strm a
tailP -> Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (Parsec err strm a)
 -> Parsec err strm (Either a (Parsec err strm a)))
-> Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall a b. (a -> b) -> a -> b
$ Parsec err strm a -> Either a (Parsec err strm a)
forall a b. b -> Either a b
Right (Parsec err strm a -> Either a (Parsec err strm a))
-> Parsec err strm a -> Either a (Parsec err strm a)
forall a b. (a -> b) -> a -> b
$ String -> Parsec err strm a -> Parsec err strm a
forall e s (m :: * -> *) a.
(VisualStream s, ShowErrorComponent e, Show a) =>
String -> ParsecT e s m a -> ParsecT e s m a
Megaparsec.dbg (String
label String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/tail") Parsec err strm a
tailP

-- |
-- Filter the results of parser based on a predicate,
-- failing with a parameterized message.
filter :: (Ord err, Stream strm) => (a -> String) -> (a -> Bool) -> HeadedParsec err strm a -> HeadedParsec err strm a
filter :: (a -> String)
-> (a -> Bool)
-> HeadedParsec err strm a
-> HeadedParsec err strm a
filter a -> String
err a -> Bool
pred = (Parsec err strm (Either a (Parsec err strm a))
 -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a -> HeadedParsec err strm a
forall err1 strm1 res1 err2 strm2 res2.
(Parsec err1 strm1 (Either res1 (Parsec err1 strm1 res1))
 -> Parsec err2 strm2 (Either res2 (Parsec err2 strm2 res2)))
-> HeadedParsec err1 strm1 res1 -> HeadedParsec err2 strm2 res2
mapParsec ((Parsec err strm (Either a (Parsec err strm a))
  -> Parsec err strm (Either a (Parsec err strm a)))
 -> HeadedParsec err strm a -> HeadedParsec err strm a)
-> (Parsec err strm (Either a (Parsec err strm a))
    -> Parsec err strm (Either a (Parsec err strm a)))
-> HeadedParsec err strm a
-> HeadedParsec err strm a
forall a b. (a -> b) -> a -> b
$ \Parsec err strm (Either a (Parsec err strm a))
p -> do
  Either a (Parsec err strm a)
junction <- Parsec err strm (Either a (Parsec err strm a))
p
  case Either a (Parsec err strm a)
junction of
    Left a
a ->
      if a -> Bool
pred a
a
        then Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a (Parsec err strm a)
forall a b. a -> Either a b
Left a
a)
        else String -> Parsec err strm (Either a (Parsec err strm a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (a -> String
err a
a)
    Right Parsec err strm a
tailP -> Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (Parsec err strm a)
 -> Parsec err strm (Either a (Parsec err strm a)))
-> Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall a b. (a -> b) -> a -> b
$
      Parsec err strm a -> Either a (Parsec err strm a)
forall a b. b -> Either a b
Right (Parsec err strm a -> Either a (Parsec err strm a))
-> Parsec err strm a -> Either a (Parsec err strm a)
forall a b. (a -> b) -> a -> b
$ do
        a
a <- Parsec err strm a
tailP
        if a -> Bool
pred a
a
          then a -> Parsec err strm a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
          else String -> Parsec err strm a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (a -> String
err a
a)

-- *

-- |
-- Lift a megaparsec parser as a head parser.
head :: (Ord err, Stream strm) => Parsec err strm a -> HeadedParsec err strm a
head :: Parsec err strm a -> HeadedParsec err strm a
head = Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either a (Parsec err strm a))
 -> HeadedParsec err strm a)
-> (Parsec err strm a
    -> Parsec err strm (Either a (Parsec err strm a)))
-> Parsec err strm a
-> HeadedParsec err strm a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> Either a (Parsec err strm a))
-> Parsec err strm a
-> Parsec err strm (Either a (Parsec err strm a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a (Parsec err strm a)
forall a b. a -> Either a b
Left

-- |
-- Lift a megaparsec parser as a tail parser.
--
-- Composing consecutive tails results in one tail.
--
-- Composing consecutive head and tail leaves the head still composable with preceding head.
tail :: (Stream strm) => Parsec err strm a -> HeadedParsec err strm a
tail :: Parsec err strm a -> HeadedParsec err strm a
tail = Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either a (Parsec err strm a))
 -> HeadedParsec err strm a)
-> (Parsec err strm a
    -> Parsec err strm (Either a (Parsec err strm a)))
-> Parsec err strm a
-> HeadedParsec err strm a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either a (Parsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (Parsec err strm a)
 -> Parsec err strm (Either a (Parsec err strm a)))
-> (Parsec err strm a -> Either a (Parsec err strm a))
-> Parsec err strm a
-> Parsec err strm (Either a (Parsec err strm a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsec err strm a -> Either a (Parsec err strm a)
forall a b. b -> Either a b
Right

-- |
-- Lift both head and tail megaparsec parsers, composing their results.
headAndTail :: (Ord err, Stream strm) => (head -> tail -> a) -> Parsec err strm head -> Parsec err strm tail -> HeadedParsec err strm a
headAndTail :: (head -> tail -> a)
-> Parsec err strm head
-> Parsec err strm tail
-> HeadedParsec err strm a
headAndTail head -> tail -> a
fn Parsec err strm head
headP Parsec err strm tail
tailP = Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Parsec err strm (Either a (Parsec err strm a))
 -> HeadedParsec err strm a)
-> Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
forall a b. (a -> b) -> a -> b
$ do
  head
a <- Parsec err strm head
headP
  return $
    Parsec err strm a -> Either a (Parsec err strm a)
forall a b. b -> Either a b
Right (Parsec err strm a -> Either a (Parsec err strm a))
-> Parsec err strm a -> Either a (Parsec err strm a)
forall a b. (a -> b) -> a -> b
$ do
      tail
b <- Parsec err strm tail
tailP
      return (head -> tail -> a
fn head
a tail
b)

-- |
-- Lift a megaparsec parser.
parse :: (Ord err, Stream strm) => Parsec err strm a -> HeadedParsec err strm a
parse :: Parsec err strm a -> HeadedParsec err strm a
parse = Parsec err strm a -> HeadedParsec err strm a
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
head

-- * Control

-- |
-- Make all the following parsers compose as tail.
endHead :: (Stream strm) => HeadedParsec err strm ()
endHead :: HeadedParsec err strm ()
endHead = Parsec err strm (Either () (Parsec err strm ()))
-> HeadedParsec err strm ()
forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (Either () (Parsec err strm ())
-> Parsec err strm (Either () (Parsec err strm ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Parsec err strm () -> Either () (Parsec err strm ())
forall a b. b -> Either a b
Right (() -> Parsec err strm ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())))