src/Darcs/Patch/ReadMonads.hs

   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