    module Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,
                            parse_strictly, parse_lazily,
                            peek_input,
                            lex_char, lex_string, lex_strings, lex_eof,
                            my_lex) where

    import ByteStringUtils ( dropSpace, breakSpace )
    import qualified Data.ByteString as B (null, empty, ByteString)
    import qualified Data.ByteString.Char8 as BC (unpack, pack)

    lex_char :: ParserM m => Char -> m ()
    lex_char c = lex_string [c]

    lex_string :: ParserM m => String -> m ()
    lex_string str = work
               $ \s -> case my_lex s of
                           Just (xs, ys) | xs == BC.pack str -> Just ((), ys)
                           _ -> Nothing

    lex_eof :: ParserM m => m ()
    lex_eof = work
            $ \s -> if B.null (dropSpace s)
                    then Just ((), B.empty)
                    else Nothing

    lex_strings :: ParserM m => [String] -> m String
    lex_strings str =
        work $ \s ->
        case my_lex s of
        Just (xs, ys) | xs' `elem` str -> Just (xs', ys)
            where xs' = BC.unpack xs
        _ -> Nothing

    my_lex :: B.ByteString -> Maybe (B.ByteString, B.ByteString)
    my_lex s = let s' = dropSpace s
               in if B.null s'
                  then Nothing
                  else Just $ breakSpace s'

    alter_input :: ParserM m
                => (B.ByteString -> B.ByteString) -> m ()
    alter_input f = work (\s -> Just ((), f s))

    class Monad m => ParserM m where
        work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m a
        maybe_work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a)
        peek_input :: m B.ByteString

    ----- Strict Monad -----
    parse_strictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)
    parse_strictly (SM f) s = f s

    newtype SM a = SM (B.ByteString -> Maybe (a, B.ByteString))
    instance Monad SM where
        SM m >>= k = SM $ \s -> case m s of
                                    Nothing -> Nothing
                                    Just (x, s') ->
                                        case k x of
                                            SM y -> y s'
        return x         = SM (\s -> Just (x,s))
        fail _           = SM (\_ -> Nothing)

    instance ParserM SM where
        work f = SM f
        maybe_work f = SM $ \s -> case f s of
                                      Just (x, s') -> Just (Just x, s')
                                      Nothing -> Just (Nothing, s)
        peek_input = SM $ \s -> Just (s, s)

    ----- Lazy Monad -----
    parse_lazily :: LM a -> B.ByteString -> (a, B.ByteString)
    parse_lazily (LM f) s = f s

    newtype LM a = LM (B.ByteString -> (a, B.ByteString))
    instance Monad LM where
        LM m >>= k = LM $ \s -> let (x, s') = m s
                                    LM y = k x
                                in y s'
        return x = LM (\s -> (x,s))
        fail s = error s

    instance ParserM LM where
        work f = LM $ \s -> case f s of
                                Nothing -> error "parser error"
                                Just x -> x
        maybe_work f = LM $ \s -> case f s of
                                      Nothing -> (Nothing, s)
                                      Just (x, s') -> (Just x, s')
        peek_input = LM $ \s -> (s, s)