-- | This module defines our parsing monad.  In the past there have been lazy
-- and strict parsers in this module.  Currently we have only the strict
-- variant and it is used for parsing patch files.

module Darcs.Patch.ReadMonads (ParserM, Darcs.Patch.ReadMonads.take,
                        parse, parseStrictly, char, int,
                        option, choice, skipSpace, skipWhile, string,
                        lexChar, lexString, lexEof, takeTillChar,
                        myLex', anyChar, endOfInput, takeTill,
                        checkConsumes,
                        linesStartingWith, linesStartingWithEndingWith) where

import Prelude ()
import Darcs.Prelude

import Darcs.Util.ByteString ( dropSpace, breakSpace, breakFirstPS,
                         readIntPS, breakLastPS )
import qualified Data.ByteString as B (null, drop, length, tail, empty,
                                       ByteString)
import qualified Data.ByteString.Char8 as BC ( uncons, dropWhile, break
                                             , splitAt, length, head )
import Control.Applicative ( Alternative(..) )
import Data.Foldable ( asum )
import Control.Monad ( MonadPlus(..) )

-- | 'lexChar' checks if the next space delimited token from
-- the input stream matches a specific 'Char'.
-- Uses 'Maybe' inside 'ParserM' to handle failed matches, so
-- that it always returns () on success.
lexChar :: ParserM m => Char -> m ()
lexChar :: Char -> m ()
lexChar c :: Char
c = do
  m ()
forall (m :: * -> *). ParserM m => m ()
skipSpace
  Char -> m ()
forall (m :: * -> *). ParserM m => Char -> m ()
char Char
c
  () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | 'lexString' fetches the next whitespace delimited token from
-- from the input and checks if it matches the 'ByteString' input.
-- Uses 'Maybe' inside 'ParserM' to handle failed matches, so
-- that it always returns () on success.
lexString :: ParserM m => B.ByteString -> m ()
lexString :: ByteString -> m ()
lexString str :: ByteString
str = (ByteString -> Maybe (ParserState ())) -> m ()
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work
           ((ByteString -> Maybe (ParserState ())) -> m ())
-> (ByteString -> Maybe (ParserState ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> case ByteString -> Maybe (ParserState ByteString)
myLex ByteString
s of
                       Just (xs :: ByteString
xs :*: ys :: ByteString
ys) | ByteString
xs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
str -> ParserState () -> Maybe (ParserState ())
forall a. a -> Maybe a
Just (() () -> ByteString -> ParserState ()
forall a. a -> ByteString -> ParserState a
:*: ByteString
ys)
                       _ -> Maybe (ParserState ())
forall a. Maybe a
Nothing

-- | Only succeeds if the characters in the input exactly match @str@.
string :: ParserM m => B.ByteString -> m ()
string :: ByteString -> m ()
string str :: ByteString
str = (ByteString -> Maybe (ParserState ())) -> m ()
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work
        ((ByteString -> Maybe (ParserState ())) -> m ())
-> (ByteString -> Maybe (ParserState ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> case Int -> ByteString -> (ByteString, ByteString)
BC.splitAt (ByteString -> Int
BC.length ByteString
str) ByteString
s of
                  (h :: ByteString
h, t :: ByteString
t) | ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
str -> ParserState () -> Maybe (ParserState ())
forall a. a -> Maybe a
Just (() () -> ByteString -> ParserState ()
forall a. a -> ByteString -> ParserState a
:*: ByteString
t)
                  _ -> Maybe (ParserState ())
forall a. Maybe a
Nothing

-- | 'lexEof' looks for optional spaces followed by the end of input.
-- Uses 'Maybe' inside 'ParserM' to handle failed matches, so
-- that it always returns () on success.
lexEof :: ParserM m => m ()
lexEof :: m ()
lexEof = (ByteString -> Maybe (ParserState ())) -> m ()
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work
        ((ByteString -> Maybe (ParserState ())) -> m ())
-> (ByteString -> Maybe (ParserState ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> if ByteString -> Bool
B.null (ByteString -> ByteString
dropSpace ByteString
s)
                then ParserState () -> Maybe (ParserState ())
forall a. a -> Maybe a
Just (() () -> ByteString -> ParserState ()
forall a. a -> ByteString -> ParserState a
:*: ByteString
B.empty)
                else Maybe (ParserState ())
forall a. Maybe a
Nothing

-- | 'myLex' drops leading spaces and then breaks the string at the
-- next space.  Returns 'Nothing' when the string is empty after
-- dropping leading spaces, otherwise it returns the first sequence
-- of non-spaces and the remainder of the input.
myLex :: B.ByteString -> Maybe (ParserState B.ByteString)
myLex :: ByteString -> Maybe (ParserState ByteString)
myLex s :: ByteString
s = let s' :: ByteString
s' = ByteString -> ByteString
dropSpace ByteString
s
           in if ByteString -> Bool
B.null ByteString
s'
              then Maybe (ParserState ByteString)
forall a. Maybe a
Nothing
              else ParserState ByteString -> Maybe (ParserState ByteString)
forall a. a -> Maybe a
Just (ParserState ByteString -> Maybe (ParserState ByteString))
-> ParserState ByteString -> Maybe (ParserState ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ParserState ByteString
forall a. (a, ByteString) -> ParserState a
stuple ((ByteString, ByteString) -> ParserState ByteString)
-> (ByteString, ByteString) -> ParserState ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
breakSpace ByteString
s'

-- | Like 'myLex' except that it is in ParserM
myLex' :: ParserM m => m B.ByteString
myLex' :: m ByteString
myLex' = (ByteString -> Maybe (ParserState ByteString)) -> m ByteString
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ByteString -> Maybe (ParserState ByteString)
myLex

-- | Accepts the next character and returns it.  Only fails at end of
-- input.
anyChar :: ParserM m => m Char
anyChar :: m Char
anyChar = (ByteString -> Maybe (ParserState Char)) -> m Char
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState Char)) -> m Char)
-> (ByteString -> Maybe (ParserState Char)) -> m Char
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> (Char, ByteString) -> ParserState Char
forall a. (a, ByteString) -> ParserState a
stuple ((Char, ByteString) -> ParserState Char)
-> Maybe (Char, ByteString) -> Maybe (ParserState Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Char, ByteString)
BC.uncons ByteString
s

-- | Only succeeds at end of input, consumes no characters.
endOfInput :: ParserM m => m ()
endOfInput :: m ()
endOfInput = (ByteString -> Maybe (ParserState ())) -> m ()
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState ())) -> m ())
-> (ByteString -> Maybe (ParserState ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> if ByteString -> Bool
B.null ByteString
s
                            then ParserState () -> Maybe (ParserState ())
forall a. a -> Maybe a
Just (() () -> ByteString -> ParserState ()
forall a. a -> ByteString -> ParserState a
:*: ByteString
s)
                            else Maybe (ParserState ())
forall a. Maybe a
Nothing

-- | Accepts only the specified character.  Consumes a character, if
-- available.
char :: ParserM m => Char -> m ()
char :: Char -> m ()
char c :: Char
c = (ByteString -> Maybe (ParserState ())) -> m ()
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState ())) -> m ())
-> (ByteString -> Maybe (ParserState ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s ->
  case ByteString -> Maybe (Char, ByteString)
BC.uncons ByteString
s of
  Just (c' :: Char
c', s' :: ByteString
s') | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' -> ParserState () -> Maybe (ParserState ())
forall a. a -> Maybe a
Just (() () -> ByteString -> ParserState ()
forall a. a -> ByteString -> ParserState a
:*: ByteString
s')
  _ -> Maybe (ParserState ())
forall a. Maybe a
Nothing

-- | Parse an integer and return it.  Skips leading whitespaces and
-- | uses the efficient ByteString readInt.
int :: ParserM m => m Int
int :: m Int
int = (ByteString -> Maybe (ParserState Int)) -> m Int
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState Int)) -> m Int)
-> (ByteString -> Maybe (ParserState Int)) -> m Int
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> (Int, ByteString) -> ParserState Int
forall a. (a, ByteString) -> ParserState a
stuple ((Int, ByteString) -> ParserState Int)
-> Maybe (Int, ByteString) -> Maybe (ParserState Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Int, ByteString)
readIntPS ByteString
s

-- | Discards spaces until a non-space character is encountered.
-- Always succeeds.
skipSpace :: ParserM m => m ()
skipSpace :: m ()
skipSpace = (ByteString -> ByteString) -> m ()
forall (m :: * -> *).
ParserM m =>
(ByteString -> ByteString) -> m ()
alterInput ByteString -> ByteString
dropSpace

-- | Discards any characters as long as @p@ returns True.  Always
-- | succeeds.
skipWhile :: ParserM m => (Char -> Bool) -> m ()
skipWhile :: (Char -> Bool) -> m ()
skipWhile p :: Char -> Bool
p = (ByteString -> ByteString) -> m ()
forall (m :: * -> *).
ParserM m =>
(ByteString -> ByteString) -> m ()
alterInput ((Char -> Bool) -> ByteString -> ByteString
BC.dropWhile Char -> Bool
p)

-- | Takes characters while @p@ returns True.  Always succeeds.
takeTill :: ParserM m => (Char -> Bool) -> m B.ByteString
takeTill :: (Char -> Bool) -> m ByteString
takeTill p :: Char -> Bool
p = (ByteString -> Maybe (ParserState ByteString)) -> m ByteString
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState ByteString)) -> m ByteString)
-> (ByteString -> Maybe (ParserState ByteString)) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> ParserState ByteString -> Maybe (ParserState ByteString)
forall a. a -> Maybe a
Just (ParserState ByteString -> Maybe (ParserState ByteString))
-> ParserState ByteString -> Maybe (ParserState ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ParserState ByteString
forall a. (a, ByteString) -> ParserState a
stuple ((Char -> Bool) -> ByteString -> (ByteString, ByteString)
BC.break Char -> Bool
p ByteString
s)

-- | Equivalent to @takeTill (==c)@, except that it is optimized for
-- | the equality case.
takeTillChar :: ParserM m => Char -> m B.ByteString
takeTillChar :: Char -> m ByteString
takeTillChar c :: Char
c = (ByteString -> Maybe (ParserState ByteString)) -> m ByteString
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState ByteString)) -> m ByteString)
-> (ByteString -> Maybe (ParserState ByteString)) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> ParserState ByteString -> Maybe (ParserState ByteString)
forall a. a -> Maybe a
Just (ParserState ByteString -> Maybe (ParserState ByteString))
-> ParserState ByteString -> Maybe (ParserState ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ParserState ByteString
forall a. (a, ByteString) -> ParserState a
stuple ((Char -> Bool) -> ByteString -> (ByteString, ByteString)
BC.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) ByteString
s)

-- | Takes exactly @n@ bytes, or fails.
take :: ParserM m => Int -> m B.ByteString
take :: Int -> m ByteString
take n :: Int
n = (ByteString -> Maybe (ParserState ByteString)) -> m ByteString
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState ByteString)) -> m ByteString)
-> (ByteString -> Maybe (ParserState ByteString)) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> if ByteString -> Int
B.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
                        then ParserState ByteString -> Maybe (ParserState ByteString)
forall a. a -> Maybe a
Just (ParserState ByteString -> Maybe (ParserState ByteString))
-> ParserState ByteString -> Maybe (ParserState ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ParserState ByteString
forall a. (a, ByteString) -> ParserState a
stuple ((ByteString, ByteString) -> ParserState ByteString)
-> (ByteString, ByteString) -> ParserState ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
BC.splitAt Int
n ByteString
s
                        else Maybe (ParserState ByteString)
forall a. Maybe a
Nothing

-- | This is a highly optimized way to read lines that start with a
-- particular character.  To implement this efficiently we need access
-- to the parser's internal state.  If this is implemented in terms of
-- the other primitives for the parser it requires us to consume one
-- character at a time.  That leads to @(>>=)@ wasting significant
-- time.
linesStartingWith :: ParserM m => Char -> m [B.ByteString]
linesStartingWith :: Char -> m [ByteString]
linesStartingWith c :: Char
c = (ByteString -> Maybe (ParserState [ByteString])) -> m [ByteString]
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState [ByteString]))
 -> m [ByteString])
-> (ByteString -> Maybe (ParserState [ByteString]))
-> m [ByteString]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> Maybe (ParserState [ByteString])
linesStartingWith' Char
c

-- | Helper function for 'linesStartingWith'.
linesStartingWith' :: Char -> B.ByteString -> Maybe (ParserState [B.ByteString])
linesStartingWith' :: Char -> ByteString -> Maybe (ParserState [ByteString])
linesStartingWith' c :: Char
c thes :: ByteString
thes =
    ParserState [ByteString] -> Maybe (ParserState [ByteString])
forall a. a -> Maybe a
Just ([ByteString] -> ByteString -> ParserState [ByteString]
lsw [] ByteString
thes)
    where lsw :: [ByteString] -> ByteString -> ParserState [ByteString]
lsw acc :: [ByteString]
acc s :: ByteString
s | ByteString -> Bool
B.null ByteString
s Bool -> Bool -> Bool
|| ByteString -> Char
BC.head ByteString
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
acc [ByteString] -> ByteString -> ParserState [ByteString]
forall a. a -> ByteString -> ParserState a
:*: ByteString
s
          lsw acc :: [ByteString]
acc s :: ByteString
s = let s' :: ByteString
s' = ByteString -> ByteString
B.tail ByteString
s
                  in case Char -> ByteString -> Maybe (ByteString, ByteString)
breakFirstPS '\n' ByteString
s' of
                     Just (l :: ByteString
l, r :: ByteString
r) -> [ByteString] -> ByteString -> ParserState [ByteString]
lsw (ByteString
lByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
acc) ByteString
r
                     Nothing -> [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
s'ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
acc) [ByteString] -> ByteString -> ParserState [ByteString]
forall a. a -> ByteString -> ParserState a
:*: ByteString
B.empty

-- | This is a highly optimized way to read lines that start with a
-- particular character, and stops when it reaches a particular |
-- character.  See 'linesStartingWith' for details on why this |
-- defined here as a primitive.
linesStartingWithEndingWith :: ParserM m => Char -> Char -> m [B.ByteString]
linesStartingWithEndingWith :: Char -> Char -> m [ByteString]
linesStartingWithEndingWith st :: Char
st en :: Char
en = (ByteString -> Maybe (ParserState [ByteString])) -> m [ByteString]
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work ((ByteString -> Maybe (ParserState [ByteString]))
 -> m [ByteString])
-> (ByteString -> Maybe (ParserState [ByteString]))
-> m [ByteString]
forall a b. (a -> b) -> a -> b
$ Char -> Char -> ByteString -> Maybe (ParserState [ByteString])
linesStartingWithEndingWith' Char
st Char
en

-- | Helper function for 'linesStartingWithEndingWith'.
linesStartingWithEndingWith' :: Char -> Char -> B.ByteString
                             -> Maybe (ParserState [B.ByteString])
linesStartingWithEndingWith' :: Char -> Char -> ByteString -> Maybe (ParserState [ByteString])
linesStartingWithEndingWith' st :: Char
st en :: Char
en = ByteString -> Maybe (ParserState [ByteString])
lswew
    where
  lswew :: ByteString -> Maybe (ParserState [ByteString])
lswew x :: ByteString
x
    | ByteString -> Bool
B.null ByteString
x = Maybe (ParserState [ByteString])
forall a. Maybe a
Nothing
    | ByteString -> Char
BC.head ByteString
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
en = ParserState [ByteString] -> Maybe (ParserState [ByteString])
forall a. a -> Maybe a
Just (ParserState [ByteString] -> Maybe (ParserState [ByteString]))
-> ParserState [ByteString] -> Maybe (ParserState [ByteString])
forall a b. (a -> b) -> a -> b
$ [] [ByteString] -> ByteString -> ParserState [ByteString]
forall a. a -> ByteString -> ParserState a
:*: ByteString -> ByteString
B.tail ByteString
x
    | ByteString -> Char
BC.head ByteString
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
st = Maybe (ParserState [ByteString])
forall a. Maybe a
Nothing
    | Bool
otherwise = case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BC.break ('\n' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.tail ByteString
x of
              (l :: ByteString
l,r :: ByteString
r) -> case ByteString -> Maybe (ParserState [ByteString])
lswew (ByteString -> Maybe (ParserState [ByteString]))
-> ByteString -> Maybe (ParserState [ByteString])
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.tail ByteString
r of
                       Just (ls :: [ByteString]
ls :*: r' :: ByteString
r') -> ParserState [ByteString] -> Maybe (ParserState [ByteString])
forall a. a -> Maybe a
Just ((ByteString
lByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
ls) [ByteString] -> ByteString -> ParserState [ByteString]
forall a. a -> ByteString -> ParserState a
:*: ByteString
r')
                       Nothing ->
                           case Char -> ByteString -> Maybe (ByteString, ByteString)
breakLastPS Char
en ByteString
l of
                           Just (l2 :: ByteString
l2,_) ->
                               ParserState [ByteString] -> Maybe (ParserState [ByteString])
forall a. a -> Maybe a
Just ([ByteString
l2] [ByteString] -> ByteString -> ParserState [ByteString]
forall a. a -> ByteString -> ParserState a
:*: Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
l2Int -> Int -> Int
forall a. Num a => a -> a -> a
+2) ByteString
x)
                           Nothing -> Maybe (ParserState [ByteString])
forall a. Maybe a
Nothing


-- | Applies a function to the input stream and discards the
-- result of the function.
alterInput :: ParserM m
            => (B.ByteString -> B.ByteString) -> m ()
alterInput :: (ByteString -> ByteString) -> m ()
alterInput f :: ByteString -> ByteString
f = (ByteString -> Maybe (ParserState ())) -> m ()
forall (m :: * -> *) a.
ParserM m =>
(ByteString -> Maybe (ParserState a)) -> m a
work (\s :: ByteString
s -> ParserState () -> Maybe (ParserState ())
forall a. a -> Maybe a
Just (() () -> ByteString -> ParserState ()
forall a. a -> ByteString -> ParserState a
:*: ByteString -> ByteString
f ByteString
s))

-- | If @p@ fails it returns @x@, otherwise it returns the result of @p@.
option :: Alternative f => a -> f a -> f a
option :: a -> f a -> f a
option x :: a
x p :: f a
p = f a
p f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Attempts each option until one succeeds.
choice :: Alternative f => [f a] -> f a
choice :: [f a] -> f a
choice = [f a] -> f a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum

-- |Ensure that a parser consumes input when producing a result
-- Causes the initial state of the input stream to be held on to while the
-- parser runs, so use with caution.
checkConsumes :: ParserM m => m a -> m a
checkConsumes :: m a -> m a
checkConsumes parser :: m a
parser = do
   Int
x <- ByteString -> Int
B.length (ByteString -> Int) -> m ByteString -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ByteString
forall (m :: * -> *). ParserM m => m ByteString
peekInput
   a
res <- m a
parser
   Int
x' <- ByteString -> Int
B.length (ByteString -> Int) -> m ByteString -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ByteString
forall (m :: * -> *). ParserM m => m ByteString
peekInput
   if Int
x' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x then a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res else m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

class (Functor m, Applicative m, Alternative m, Monad m, MonadPlus m) => ParserM m where
    -- | Applies a parsing function inside the 'ParserM' monad.
    work :: (B.ByteString -> Maybe (ParserState a)) -> m a
    -- | Allows for the inspection of the input that is yet to be parsed.
    peekInput :: m B.ByteString
    -- | Run the parser
    parse :: m a -> B.ByteString -> Maybe (a, B.ByteString)

----- Strict Monad -----
-- | 'parseStrictly' applies the parser functions to a string
-- and checks that each parser produced a result as it goes.
-- The strictness is in the 'ParserM' instance for 'SM'.
parseStrictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)
parseStrictly :: SM a -> ByteString -> Maybe (a, ByteString)
parseStrictly (SM f :: ByteString -> Maybe (ParserState a)
f) s :: ByteString
s = case ByteString -> Maybe (ParserState a)
f ByteString
s of
  Just (a :: a
a :*: r :: ByteString
r) -> (a, ByteString) -> Maybe (a, ByteString)
forall a. a -> Maybe a
Just (a
a, ByteString
r)
  _ -> Maybe (a, ByteString)
forall a. Maybe a
Nothing

-- | ParserState represents the internal state of the parser.  We make it
-- strict and specialize it on ByteString.  This is purely to help GHC
-- optimize.  If performance were not a concern, it could be replaced
-- with @(a, ByteString)@.
data ParserState a = !a :*: !B.ByteString

-- | Convert from a lazy tuple to a strict tuple.
stuple :: (a, B.ByteString) -> ParserState a
stuple :: (a, ByteString) -> ParserState a
stuple (a :: a
a, b :: ByteString
b) = a
a a -> ByteString -> ParserState a
forall a. a -> ByteString -> ParserState a
:*: ByteString
b

-- | 'SM' is the Strict Monad for parsing.
newtype SM a = SM (B.ByteString -> Maybe (ParserState a))

bindSM :: SM a -> (a -> SM b) -> SM b
bindSM :: SM a -> (a -> SM b) -> SM b
bindSM (SM m :: ByteString -> Maybe (ParserState a)
m) k :: a -> SM b
k = (ByteString -> Maybe (ParserState b)) -> SM b
forall a. (ByteString -> Maybe (ParserState a)) -> SM a
SM ((ByteString -> Maybe (ParserState b)) -> SM b)
-> (ByteString -> Maybe (ParserState b)) -> SM b
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> case ByteString -> Maybe (ParserState a)
m ByteString
s of
                             Nothing -> Maybe (ParserState b)
forall a. Maybe a
Nothing
                             Just (x :: a
x :*: s' :: ByteString
s') ->
                               case a -> SM b
k a
x of
                               SM y :: ByteString -> Maybe (ParserState b)
y -> ByteString -> Maybe (ParserState b)
y ByteString
s'
{-# INLINE bindSM #-}
returnSM :: a -> SM a
returnSM :: a -> SM a
returnSM x :: a
x = (ByteString -> Maybe (ParserState a)) -> SM a
forall a. (ByteString -> Maybe (ParserState a)) -> SM a
SM (\s :: ByteString
s -> ParserState a -> Maybe (ParserState a)
forall a. a -> Maybe a
Just (a
x a -> ByteString -> ParserState a
forall a. a -> ByteString -> ParserState a
:*: ByteString
s))
{-# INLINE returnSM #-}
failSM :: String -> SM a
failSM :: String -> SM a
failSM _ = (ByteString -> Maybe (ParserState a)) -> SM a
forall a. (ByteString -> Maybe (ParserState a)) -> SM a
SM (\_ -> Maybe (ParserState a)
forall a. Maybe a
Nothing)
{-# INLINE failSM #-}

instance Monad SM where
    >>= :: SM a -> (a -> SM b) -> SM b
(>>=)  = SM a -> (a -> SM b) -> SM b
forall a b. SM a -> (a -> SM b) -> SM b
bindSM
    return :: a -> SM a
return = a -> SM a
forall a. a -> SM a
returnSM

instance ParserM SM where
    work :: (ByteString -> Maybe (ParserState a)) -> SM a
work = (ByteString -> Maybe (ParserState a)) -> SM a
forall a. (ByteString -> Maybe (ParserState a)) -> SM a
SM
    peekInput :: SM ByteString
peekInput = (ByteString -> Maybe (ParserState ByteString)) -> SM ByteString
forall a. (ByteString -> Maybe (ParserState a)) -> SM a
SM ((ByteString -> Maybe (ParserState ByteString)) -> SM ByteString)
-> (ByteString -> Maybe (ParserState ByteString)) -> SM ByteString
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s -> ParserState ByteString -> Maybe (ParserState ByteString)
forall a. a -> Maybe a
Just (ByteString
s ByteString -> ByteString -> ParserState ByteString
forall a. a -> ByteString -> ParserState a
:*: ByteString
s)
    parse :: SM a -> ByteString -> Maybe (a, ByteString)
parse = SM a -> ByteString -> Maybe (a, ByteString)
forall a. SM a -> ByteString -> Maybe (a, ByteString)
parseStrictly

-- The following instances allow us to use more conventional
-- interfaces provided by other parser libraries. The instances are
-- defined using bindSM, returnSM, and failSM to avoid any infinite,
-- or even unneccessary, recursion of instances between between
-- ParserM and Monad.  Other recursive uses will be fine, such as
-- (<|>) = mplus.
instance MonadPlus SM where
  mzero :: SM a
mzero = String -> SM a
forall a. String -> SM a
failSM ""
  -- | Over using mplus can lead to space leaks.  It's best to push
  -- the use of mplus as far down as possible, because until the the
  -- first parameter completes, we must hold on to the input.
  mplus :: SM a -> SM a -> SM a
mplus (SM a :: ByteString -> Maybe (ParserState a)
a) (SM b :: ByteString -> Maybe (ParserState a)
b) = (ByteString -> Maybe (ParserState a)) -> SM a
forall a. (ByteString -> Maybe (ParserState a)) -> SM a
SM ((ByteString -> Maybe (ParserState a)) -> SM a)
-> (ByteString -> Maybe (ParserState a)) -> SM a
forall a b. (a -> b) -> a -> b
$ \s :: ByteString
s ->
    case ByteString -> Maybe (ParserState a)
a ByteString
s of
      Nothing -> ByteString -> Maybe (ParserState a)
b ByteString
s
      r :: Maybe (ParserState a)
r -> Maybe (ParserState a)
r

instance Functor SM where
  fmap :: (a -> b) -> SM a -> SM b
fmap f :: a -> b
f m :: SM a
m = SM a
m SM a -> (a -> SM b) -> SM b
forall a b. SM a -> (a -> SM b) -> SM b
`bindSM` (b -> SM b
forall a. a -> SM a
returnSM (b -> SM b) -> (a -> b) -> a -> SM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative SM where
  pure :: a -> SM a
pure = a -> SM a
forall a. a -> SM a
returnSM
  a :: SM (a -> b)
a <*> :: SM (a -> b) -> SM a -> SM b
<*> b :: SM a
b =
    SM (a -> b)
a SM (a -> b) -> ((a -> b) -> SM b) -> SM b
forall a b. SM a -> (a -> SM b) -> SM b
`bindSM` \c :: a -> b
c ->
    SM a
b SM a -> (a -> SM b) -> SM b
forall a b. SM a -> (a -> SM b) -> SM b
`bindSM` \d :: a
d ->
    b -> SM b
forall a. a -> SM a
returnSM (a -> b
c a
d)

instance Alternative SM where
  empty :: SM a
empty = String -> SM a
forall a. String -> SM a
failSM ""
  <|> :: SM a -> SM a -> SM a
(<|>) = SM a -> SM a -> SM a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus