module PatchReadMonads (Stringalike(..),
                        ParserM, work, maybe_work, alter_input,
                        parse_strictly, parse_lazily,
                        peek_input,
                        lex_char, lex_string, lex_strings, lex_eof,
                        my_lex) where

import Stringalike ( Stringalike(..) )

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

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

lex_eof :: (Stringalike s, ParserM m) => m s ()
lex_eof = work
        $ \s -> if sal_null (sal_dropWhite s)
                then (Just ((), sal_empty))
                else Nothing

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

my_lex :: Stringalike s => s -> Maybe (s, s)
my_lex s = let s' = sal_dropWhite s
           in if sal_null s'
              then Nothing
              else Just $ sal_breakWhite s'

alter_input :: (Stringalike s, ParserM m)
            => (s -> s) -> m s ()
alter_input f = work (\s -> Just ((), f s))

class ParserM m where
    work :: (s -> Maybe (a, s)) -> m s a
    maybe_work :: (s -> Maybe (a, s)) -> m s (Maybe a)
    peek_input :: m s s

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

newtype SM s a = SM (s -> Maybe (a, s))
instance Monad (SM s) 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 s a -> s -> (a, s)
parse_lazily (LM f) s = f s

newtype LM s a = LM (s -> (a, s))
instance Monad (LM s) 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)