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.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 :: 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

-- |
-- Alternation is performed only the basis of heads.
-- Bodies do not participate.
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)

-- |
-- Alternation is performed only the basis of heads.
-- Bodies do not participate.
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

-- * Execution

-- |
-- Convert headed parser into megaparsec parser.
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

-- * 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 :: 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)

-- * 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 :: 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 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 :: 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)

-- |
-- Adaptation of 'Megaparsec.hidden'.
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

-- |
-- 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 :: (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 the results of parser based on a predicate,
-- failing with a parameterized message.
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)

-- |
-- Lift a megaparsec parser as a head parser.
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

-- |
-- Lift a megaparsec parser.
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

-- * Control

-- |
-- Make all the following parsers compose as tail.
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 ())))