ReadMonads.hs

-- | 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, work, maybeWork, alterInput,
                        parseStrictly,
                        peekInput,
                        lexChar, lexString, lexStrings, lexEof,
                        myLex) where

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

-- | '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 c = lexString [c]

-- | 'lexString' fetches the next whitespace delimited token from
-- from the input and checks if it matches the 'String' input.
-- Uses 'Maybe' inside 'ParserM' to handle failed matches, so
-- that it always returns () on success.
lexString :: ParserM m => String -> m ()
lexString str = work
           $ \s -> case myLex s of
                       Just (xs, ys) | xs == BC.pack str -> Just ((), ys)
                       _ -> 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 = work
        $ \s -> if B.null (dropSpace s)
                then Just ((), B.empty)
                else Nothing

-- | Checks if any of the input 'String's match the next
-- space delimited token in the input stream.
-- Uses 'Maybe' inside 'ParserM' to handle failed matches,
-- on success it returns the matching 'String'.
lexStrings :: ParserM m => [String] -> m String
lexStrings str =
    work $ \s ->
    case myLex s of
    Just (xs, ys) | xs' `elem` str -> Just (xs', ys)
        where xs' = BC.unpack xs
    _ -> 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 (B.ByteString, B.ByteString)
myLex s = let s' = dropSpace s
           in if B.null s'
              then Nothing
              else Just $ breakSpace s'

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

class Monad m => ParserM m where
    -- | Applies a parsing function inside the 'ParserM' monad.
    work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m a
    -- | Applies a parsing function, that can return 'Nothing',
    -- inside the 'ParserM' monad.
    maybeWork :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a)
    -- | Allows for the inspection of the input that is yet to be parsed.
    peekInput :: m 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 f) s = f s

-- | 'SM' is the Strict Monad for parsing.
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
    maybeWork f = SM $ \s -> case f s of
                                  Just (x, s') -> Just (Just x, s')
                                  Nothing -> Just (Nothing, s)
    peekInput = SM $ \s -> Just (s, s)