1 
    2 module Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,
    3                         parse_strictly, parse_lazily,
    4                         peek_input,
    5                         lex_char, lex_string, lex_strings, lex_eof,
    6                         my_lex) where
    7 
    8 import ByteStringUtils ( dropSpace, breakSpace )
    9 import qualified Data.ByteString as B (null, empty, ByteString)
   10 import qualified Data.ByteString.Char8 as BC (unpack, pack)
   11 
   12 lex_char :: ParserM m => Char -> m ()
   13 lex_char c = lex_string [c]
   14 
   15 lex_string :: ParserM m => String -> m ()
   16 lex_string str = work
   17            $ \s -> case my_lex s of
   18                        Just (xs, ys) | xs == BC.pack str -> Just ((), ys)
   19                        _ -> Nothing
   20 
   21 lex_eof :: ParserM m => m ()
   22 lex_eof = work
   23         $ \s -> if B.null (dropSpace s)
   24                 then Just ((), B.empty)
   25                 else Nothing
   26 
   27 lex_strings :: ParserM m => [String] -> m String
   28 lex_strings str =
   29     work $ \s ->
   30     case my_lex s of
   31     Just (xs, ys) | xs' `elem` str -> Just (xs', ys)
   32         where xs' = BC.unpack xs
   33     _ -> Nothing
   34 
   35 my_lex :: B.ByteString -> Maybe (B.ByteString, B.ByteString)
   36 my_lex s = let s' = dropSpace s
   37            in if B.null s'
   38               then Nothing
   39               else Just $ breakSpace s'
   40 
   41 alter_input :: ParserM m
   42             => (B.ByteString -> B.ByteString) -> m ()
   43 alter_input f = work (\s -> Just ((), f s))
   44 
   45 class Monad m => ParserM m where
   46     work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m a
   47     maybe_work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a)
   48     peek_input :: m B.ByteString
   49 
   50 ----- Strict Monad -----
   51 parse_strictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)
   52 parse_strictly (SM f) s = f s
   53 
   54 newtype SM a = SM (B.ByteString -> Maybe (a, B.ByteString))
   55 instance Monad SM where
   56     SM m >>= k = SM $ \s -> case m s of
   57                                 Nothing -> Nothing
   58                                 Just (x, s') ->
   59                                     case k x of
   60                                         SM y -> y s'
   61     return x         = SM (\s -> Just (x,s))
   62     fail _           = SM (\_ -> Nothing)
   63 
   64 instance ParserM SM where
   65     work f = SM f
   66     maybe_work f = SM $ \s -> case f s of
   67                                   Just (x, s') -> Just (Just x, s')
   68                                   Nothing -> Just (Nothing, s)
   69     peek_input = SM $ \s -> Just (s, s)
   70 
   71 ----- Lazy Monad -----
   72 parse_lazily :: LM a -> B.ByteString -> (a, B.ByteString)
   73 parse_lazily (LM f) s = f s
   74 
   75 newtype LM a = LM (B.ByteString -> (a, B.ByteString))
   76 instance Monad LM where
   77     LM m >>= k = LM $ \s -> let (x, s') = m s
   78                                 LM y = k x
   79                             in y s'
   80     return x = LM (\s -> (x,s))
   81     fail s = error s
   82 
   83 instance ParserM LM where
   84     work f = LM $ \s -> case f s of
   85                             Nothing -> error "parser error"
   86                             Just x -> x
   87     maybe_work f = LM $ \s -> case f s of
   88                                   Nothing -> (Nothing, s)
   89                                   Just (x, s') -> (Just x, s')
   90     peek_input = LM $ \s -> (s, s)
   91