module HeadedMegaparsec
(
HeadedParsec,
toParsec,
wrapToHead,
label,
hidden,
dbg,
filter,
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.Debug as Megaparsec
newtype HeadedParsec err strm a = HeadedParsec (Parsec err strm (Either a (Parsec err strm a)))
data Showable a = Showable String a
instance Show (Showable a) where
show :: Showable a -> String
show (Showable String
msg a
_) = String
msg
instance Functor (HeadedParsec err strm) where
fmap :: forall a b.
(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) = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
fn (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 :: forall a. a -> HeadedParsec err strm a
pure = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> Either a b
Left
<*> :: forall a b.
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) = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (a -> b
aToB a
a))
Right Parsec err strm a
tailP2 -> forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
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 -> 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 :: forall a b.
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) = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (a -> b
aToB a
a))
Right Parsec err strm (a -> b)
tailP2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ a
a) Parsec err strm (a -> b)
tailP2))
Right Parsec err strm (Either a b)
tailP1 -> forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
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 -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
aToB a
a)
Right Parsec err strm (a -> b)
tailP2 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 :: forall a. a -> HeadedParsec err strm a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
>>= :: forall a b.
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 = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
forall a b. (a -> b) -> a -> b
$ do
a
a <- Parsec err strm a
tailP1
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm (Either a (Parsec err strm a)) -> Parsec err strm a
Megaparsec.contPossibly 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
instance (Ord err, Stream strm) => Alternative (HeadedParsec err strm) where
empty :: forall a. HeadedParsec err strm a
empty = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec forall (f :: * -> *) a. Alternative f => f a
empty
<|> :: forall a.
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) = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec err strm (Either a (Parsec err strm a))
p2)
instance (Ord err, Stream strm) => MonadPlus (HeadedParsec err strm) where
mzero :: forall a. HeadedParsec err strm a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty
mplus :: forall a.
HeadedParsec err strm a
-> HeadedParsec err strm a -> HeadedParsec err strm a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
instance (Ord err, Stream strm) => MonadFail (HeadedParsec err strm) where
fail :: forall a. String -> HeadedParsec err strm a
fail = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadFail m => String -> m a
fail
toParsec :: (Ord err, Stream strm) => HeadedParsec err strm a -> Parsec err strm a
toParsec :: forall err strm a.
(Ord err, Stream strm) =>
HeadedParsec err strm a -> Parsec err strm a
toParsec (HeadedParsec Parsec err strm (Either a (Parsec err strm a))
p) = 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
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 :: 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 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) = 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)
wrapToHead :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm a
wrapToHead :: forall err strm a.
(Ord err, Stream strm) =>
HeadedParsec err strm a -> HeadedParsec err strm a
wrapToHead = 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm (Either a (Parsec err strm a)) -> Parsec err strm a
Megaparsec.contPossibly
label :: (Ord err, Stream strm) => String -> HeadedParsec err strm a -> HeadedParsec err strm a
label :: forall err strm a.
(Ord err, Stream strm) =>
String -> HeadedParsec err strm a -> HeadedParsec err strm a
label String
label = 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 (forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
Megaparsec.label String
label)
hidden :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm a
hidden :: forall err strm a.
(Ord err, Stream strm) =>
HeadedParsec err strm a -> HeadedParsec err strm a
hidden = 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 forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.hidden
dbg :: (Megaparsec.ShowErrorComponent err, Megaparsec.VisualStream strm, Show a) => String -> HeadedParsec err strm a -> HeadedParsec err strm a
dbg :: forall err strm a.
(ShowErrorComponent err, VisualStream strm, Show a) =>
String -> HeadedParsec err strm a -> HeadedParsec err strm a
dbg String
label = 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 forall a b. (a -> b) -> a -> b
$ \Parsec err strm (Either a (ParsecT err strm Identity a))
p -> do
Showable String
_ Either a (ParsecT err strm Identity a)
junction <- forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
Megaparsec.dbg (String
label forall a. Semigroup a => a -> a -> a
<> String
"/head") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\a
a -> forall a. String -> a -> Showable a
Showable (forall a. Show a => a -> String
show a
a) (forall a b. a -> Either a b
Left a
a)) (forall a. String -> a -> Showable a
Showable String
"<tail parser>" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. b -> Either a b
Right)) Parsec err strm (Either a (ParsecT err strm Identity a))
p)
case Either a (ParsecT err strm Identity a)
junction of
Left a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left a
a)
Right ParsecT err strm Identity a
tailP -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
Megaparsec.dbg (String
label forall a. Semigroup a => a -> a -> a
<> String
"/tail") ParsecT err strm Identity a
tailP
filter :: (Stream strm) => (a -> String) -> (a -> Bool) -> HeadedParsec err strm a -> HeadedParsec err strm a
filter :: forall strm a err.
Stream strm =>
(a -> String)
-> (a -> Bool)
-> HeadedParsec err strm a
-> HeadedParsec err strm a
filter a -> String
err a -> Bool
pred = 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 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 forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left a
a)
else forall (m :: * -> *) a. MonadFail m => String -> m a
fail (a -> String
err a
a)
Right Parsec err strm a
tailP -> forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
forall a b. (a -> b) -> a -> b
$ do
a
a <- Parsec err strm a
tailP
if a -> Bool
pred a
a
then forall (m :: * -> *) a. Monad m => a -> m a
return a
a
else forall (m :: * -> *) a. MonadFail m => String -> m a
fail (a -> String
err a
a)
head :: Parsec err strm a -> HeadedParsec err strm a
head :: forall err strm a. Parsec err strm a -> HeadedParsec err strm a
head = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left
parse :: Parsec err strm a -> HeadedParsec err strm a
parse :: forall err strm a. Parsec err strm a -> HeadedParsec err strm a
parse = forall err strm a. Parsec err strm a -> HeadedParsec err strm a
head
endHead :: (Stream strm) => HeadedParsec err strm ()
endHead :: forall strm err. Stream strm => HeadedParsec err strm ()
endHead = forall err strm a.
Parsec err strm (Either a (Parsec err strm a))
-> HeadedParsec err strm a
HeadedParsec (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (forall (m :: * -> *) a. Monad m => a -> m a
return ())))