module HeadedMegaparsec
(
  -- * Types
  HeadedParsec,
  -- * Execution
  toParsec,
  -- * Transformation
  wrapToHead,
  label,
  dbg,
  filter,
  -- * Construction
  parse,
  endHead,
)
where

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

{- $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)

{-|
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 ())))