module HeadedMegaparsec.HeadedParsec
(
HeadedParsec,
toParsec,
wrapToHead,
label,
dbg,
filter,
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
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 msg _) = msg
instance Functor (HeadedParsec err strm) where
fmap fn (HeadedParsec p) = HeadedParsec (fmap (bimap fn (fmap fn)) p)
instance (Ord err, Stream strm) => Applicative (HeadedParsec err strm) where
pure = HeadedParsec . pure . Left
(<*>) (HeadedParsec p1) (HeadedParsec p2) = HeadedParsec $ do
junction1 <- p1
case junction1 of
Left aToB -> do
junction2 <- p2
case junction2 of
Left a -> return (Left (aToB a))
Right tailP2 -> return $ Right $ do
a <- tailP2
return (aToB a)
Right tailP1 -> return $ Right $ do
aToB <- tailP1
junction2 <- p2
case junction2 of
Left a -> return (aToB a)
Right tailP2 -> do
a <- tailP2
return (aToB a)
instance (Ord err, Stream strm) => Selective (HeadedParsec err strm) where
select (HeadedParsec p1) (HeadedParsec p2) = HeadedParsec $ do
junction1 <- p1
case junction1 of
Left eitherAOrB -> case eitherAOrB of
Right b -> return (Left b)
Left a -> do
junction2 <- p2
case junction2 of
Left aToB -> return (Left (aToB a))
Right tailP2 -> return (Right (fmap ($ a) tailP2))
Right tailP1 -> return $ Right $ do
eitherAOrB <- tailP1
case eitherAOrB of
Right b -> return b
Left a -> do
junction2 <- p2
case junction2 of
Left aToB -> return (aToB a)
Right tailP2 -> fmap ($ a) tailP2
instance (Ord err, Stream strm) => Monad (HeadedParsec err strm) where
return = pure
(>>=) (HeadedParsec p1) k2 = HeadedParsec $ do
junction1 <- p1
case junction1 of
Left a -> case k2 a of HeadedParsec p2 -> p2
Right tailP1 -> return $ Right $ do
a <- tailP1
Megaparsec.contPossibly $ case k2 a of HeadedParsec p2 -> p2
instance (Ord err, Stream strm) => Alternative (HeadedParsec err strm) where
empty = HeadedParsec empty
(<|>) (HeadedParsec p1) (HeadedParsec p2) = HeadedParsec (Megaparsec.try p1 <|> p2)
instance (Ord err, Stream strm) => MonadPlus (HeadedParsec err strm) where
mzero = empty
mplus = (<|>)
instance (Ord err, Stream strm) => MonadFail (HeadedParsec err strm) where
fail = HeadedParsec . fail
toParsec :: (Ord err, Stream strm) => HeadedParsec err strm a -> Parsec err strm a
toParsec (HeadedParsec p) = Megaparsec.contPossibly 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 fn (HeadedParsec p) = HeadedParsec (fn p)
wrapToHead :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm a
wrapToHead = mapParsec $ fmap Left . Megaparsec.contPossibly
label :: (Ord err, Stream strm) => String -> HeadedParsec err strm a -> HeadedParsec err strm a
label label = mapParsec (Megaparsec.label label)
dbg :: (Ord err, Megaparsec.ShowErrorComponent err, Stream strm, Show a) => String -> HeadedParsec err strm a -> HeadedParsec err strm a
dbg label = mapParsec $ \ p -> do
Showable _ junction <- Megaparsec.dbg (label <> "/head") (fmap (either (\ a -> Showable (show a) (Left a)) (Showable "<tail parser>" . Right)) p)
case junction of
Left a -> return (Left a)
Right tailP -> return $ Right $ Megaparsec.dbg (label <> "/tail") tailP
filter :: (Ord err, Stream strm) => (a -> String) -> (a -> Bool) -> HeadedParsec err strm a -> HeadedParsec err strm a
filter err pred = mapParsec $ \ p -> do
junction <- p
case junction of
Left a -> if pred a
then return (Left a)
else fail (err a)
Right tailP -> return $ Right $ do
a <- tailP
if pred a
then return a
else fail (err a)
head :: (Ord err, Stream strm) => Parsec err strm a -> HeadedParsec err strm a
head = HeadedParsec . fmap Left
tail :: (Stream strm) => Parsec err strm a -> HeadedParsec err strm a
tail = HeadedParsec . return . Right
headAndTail :: (Ord err, Stream strm) => (head -> tail -> a) -> Parsec err strm head -> Parsec err strm tail -> HeadedParsec err strm a
headAndTail fn headP tailP = HeadedParsec $ do
a <- headP
return $ Right $ do
b <- tailP
return (fn a b)
parse :: (Ord err, Stream strm) => Parsec err strm a -> HeadedParsec err strm a
parse = head
endHead :: (Stream strm) => HeadedParsec err strm ()
endHead = HeadedParsec (return (Right (return ())))