module System.Console.Haskeline.Monads(
                module System.Console.Haskeline.MonadException,
                MonadTrans(..),
                MonadIO(..),
                ReaderT,
                runReaderT,
                runReaderT',
                mapReaderT,
                asks,
                StateT,
                runStateT,
                evalStateT',
                mapStateT,
                gets,
                modify,
                update,
                MonadReader(..),
                MonadState(..),
                MaybeT(MaybeT),
                runMaybeT,
                orElse
                ) where

import Control.Applicative (Applicative(..))
import Control.Monad (ap, liftM)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Maybe (MaybeT(MaybeT),runMaybeT)
import Control.Monad.Trans.Reader hiding (ask,asks)
import qualified Control.Monad.Trans.Reader as Reader
import Data.IORef

import System.Console.Haskeline.MonadException

class Monad m => MonadReader r m where
    ask :: m r

instance Monad m => MonadReader r (ReaderT r m) where
    ask :: ReaderT r m r
ask = ReaderT r m r
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask

instance Monad m => MonadReader s (StateT s m) where
    ask :: StateT s m s
ask = StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get

instance {-# OVERLAPPABLE #-} (MonadReader r m, MonadTrans t, Monad (t m))
    => MonadReader r (t m) where
    ask :: t m r
ask = m r -> t m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask

asks :: MonadReader r m => (r -> a) -> m a
asks :: (r -> a) -> m a
asks f :: r -> a
f = (r -> a) -> m r -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM r -> a
f m r
forall r (m :: * -> *). MonadReader r m => m r
ask

class Monad m => MonadState s m where
    get :: m s
    put :: s -> m ()

gets :: MonadState s m => (s -> a) -> m a
gets :: (s -> a) -> m a
gets f :: s -> a
f = (s -> a) -> m s -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM s -> a
f m s
forall s (m :: * -> *). MonadState s m => m s
get

modify :: MonadState s m => (s -> s) -> m ()
modify :: (s -> s) -> m ()
modify f :: s -> s
f = m s
forall s (m :: * -> *). MonadState s m => m s
get m s -> (s -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (s -> m ()) -> (s -> s) -> s -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f

update :: MonadState s m => (s -> (a,s)) -> m a
update :: (s -> (a, s)) -> m a
update f :: s -> (a, s)
f = do
    s
s <- m s
forall s (m :: * -> *). MonadState s m => m s
get
    let (x :: a
x,s' :: s
s') = s -> (a, s)
f s
s
    s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s'
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

runReaderT' :: r -> ReaderT r m a -> m a
runReaderT' :: r -> ReaderT r m a -> m a
runReaderT' = (ReaderT r m a -> r -> m a) -> r -> ReaderT r m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

newtype StateT s m a = StateT { StateT s m a -> forall r. s -> m ((a -> s -> r) -> r)
getStateTFunc 
                                    :: forall r . s -> m ((a -> s -> r) -> r)}

instance Monad m => Functor (StateT s m) where
    fmap :: (a -> b) -> StateT s m a -> StateT s m b
fmap  = (a -> b) -> StateT s m a -> StateT s m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Monad m => Applicative (StateT s m) where
    pure :: a -> StateT s m a
pure x :: a
x = (forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
forall s (m :: * -> *) a.
(forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
StateT ((forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a)
-> (forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s :: s
s -> ((a -> s -> r) -> r) -> m ((a -> s -> r) -> r)
forall (m :: * -> *) a. Monad m => a -> m a
return (((a -> s -> r) -> r) -> m ((a -> s -> r) -> r))
-> ((a -> s -> r) -> r) -> m ((a -> s -> r) -> r)
forall a b. (a -> b) -> a -> b
$ \f :: a -> s -> r
f -> a -> s -> r
f a
x s
s
    <*> :: StateT s m (a -> b) -> StateT s m a -> StateT s m b
(<*>) = StateT s m (a -> b) -> StateT s m a -> StateT s m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (StateT s m) where
    return :: a -> StateT s m a
return = a -> StateT s m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    StateT f :: forall r. s -> m ((a -> s -> r) -> r)
f >>= :: StateT s m a -> (a -> StateT s m b) -> StateT s m b
>>= g :: a -> StateT s m b
g = (forall r. s -> m ((b -> s -> r) -> r)) -> StateT s m b
forall s (m :: * -> *) a.
(forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
StateT ((forall r. s -> m ((b -> s -> r) -> r)) -> StateT s m b)
-> (forall r. s -> m ((b -> s -> r) -> r)) -> StateT s m b
forall a b. (a -> b) -> a -> b
$ \s :: s
s -> do
        (a -> s -> m ((b -> s -> r) -> r)) -> m ((b -> s -> r) -> r)
useX <- s
-> m ((a -> s -> m ((b -> s -> r) -> r)) -> m ((b -> s -> r) -> r))
forall r. s -> m ((a -> s -> r) -> r)
f s
s
        (a -> s -> m ((b -> s -> r) -> r)) -> m ((b -> s -> r) -> r)
useX ((a -> s -> m ((b -> s -> r) -> r)) -> m ((b -> s -> r) -> r))
-> (a -> s -> m ((b -> s -> r) -> r)) -> m ((b -> s -> r) -> r)
forall a b. (a -> b) -> a -> b
$ \x :: a
x s' :: s
s' -> StateT s m b -> s -> m ((b -> s -> r) -> r)
forall s (m :: * -> *) a.
StateT s m a -> forall r. s -> m ((a -> s -> r) -> r)
getStateTFunc (a -> StateT s m b
g a
x) s
s'

instance MonadTrans (StateT s) where
    lift :: m a -> StateT s m a
lift m :: m a
m = (forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
forall s (m :: * -> *) a.
(forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
StateT ((forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a)
-> (forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s :: s
s -> do
        a
x <- m a
m
        ((a -> s -> r) -> r) -> m ((a -> s -> r) -> r)
forall (m :: * -> *) a. Monad m => a -> m a
return (((a -> s -> r) -> r) -> m ((a -> s -> r) -> r))
-> ((a -> s -> r) -> r) -> m ((a -> s -> r) -> r)
forall a b. (a -> b) -> a -> b
$ \f :: a -> s -> r
f -> a -> s -> r
f a
x s
s

instance MonadIO m => MonadIO (StateT s m) where
    liftIO :: IO a -> StateT s m a
liftIO = m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a) -> (IO a -> m a) -> IO a -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

mapStateT :: (forall b . m b -> n b) -> StateT s m a -> StateT s n a
mapStateT :: (forall b. m b -> n b) -> StateT s m a -> StateT s n a
mapStateT f :: forall b. m b -> n b
f (StateT m :: forall r. s -> m ((a -> s -> r) -> r)
m) = (forall r. s -> n ((a -> s -> r) -> r)) -> StateT s n a
forall s (m :: * -> *) a.
(forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
StateT (\s :: s
s -> m ((a -> s -> r) -> r) -> n ((a -> s -> r) -> r)
forall b. m b -> n b
f (s -> m ((a -> s -> r) -> r)
forall r. s -> m ((a -> s -> r) -> r)
m s
s))

runStateT :: Monad m => StateT s m a -> s -> m (a, s)
runStateT :: StateT s m a -> s -> m (a, s)
runStateT f :: StateT s m a
f s :: s
s = do
    (a -> s -> (a, s)) -> (a, s)
useXS <- StateT s m a -> s -> m ((a -> s -> (a, s)) -> (a, s))
forall s (m :: * -> *) a.
StateT s m a -> forall r. s -> m ((a -> s -> r) -> r)
getStateTFunc StateT s m a
f s
s
    (a, s) -> m (a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, s) -> m (a, s)) -> (a, s) -> m (a, s)
forall a b. (a -> b) -> a -> b
$ (a -> s -> (a, s)) -> (a, s)
useXS ((a -> s -> (a, s)) -> (a, s)) -> (a -> s -> (a, s)) -> (a, s)
forall a b. (a -> b) -> a -> b
$ \x :: a
x s' :: s
s' -> (a
x,s
s')

makeStateT :: Monad m => (s -> m (a,s)) -> StateT s m a
makeStateT :: (s -> m (a, s)) -> StateT s m a
makeStateT f :: s -> m (a, s)
f = (forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
forall s (m :: * -> *) a.
(forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
StateT ((forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a)
-> (forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s :: s
s -> do
                            (x :: a
x,s' :: s
s') <- s -> m (a, s)
f s
s
                            ((a -> s -> r) -> r) -> m ((a -> s -> r) -> r)
forall (m :: * -> *) a. Monad m => a -> m a
return (((a -> s -> r) -> r) -> m ((a -> s -> r) -> r))
-> ((a -> s -> r) -> r) -> m ((a -> s -> r) -> r)
forall a b. (a -> b) -> a -> b
$ \g :: a -> s -> r
g -> a -> s -> r
g a
x s
s'

instance Monad m => MonadState s (StateT s m) where
    get :: StateT s m s
get = (forall r. s -> m ((s -> s -> r) -> r)) -> StateT s m s
forall s (m :: * -> *) a.
(forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
StateT ((forall r. s -> m ((s -> s -> r) -> r)) -> StateT s m s)
-> (forall r. s -> m ((s -> s -> r) -> r)) -> StateT s m s
forall a b. (a -> b) -> a -> b
$ \s :: s
s -> ((s -> s -> r) -> r) -> m ((s -> s -> r) -> r)
forall (m :: * -> *) a. Monad m => a -> m a
return (((s -> s -> r) -> r) -> m ((s -> s -> r) -> r))
-> ((s -> s -> r) -> r) -> m ((s -> s -> r) -> r)
forall a b. (a -> b) -> a -> b
$ \f :: s -> s -> r
f -> s -> s -> r
f s
s s
s
    put :: s -> StateT s m ()
put s :: s
s = s
s s -> StateT s m () -> StateT s m ()
forall a b. a -> b -> b
`seq` (forall r. s -> m ((() -> s -> r) -> r)) -> StateT s m ()
forall s (m :: * -> *) a.
(forall r. s -> m ((a -> s -> r) -> r)) -> StateT s m a
StateT ((forall r. s -> m ((() -> s -> r) -> r)) -> StateT s m ())
-> (forall r. s -> m ((() -> s -> r) -> r)) -> StateT s m ()
forall a b. (a -> b) -> a -> b
$ \_ -> ((() -> s -> r) -> r) -> m ((() -> s -> r) -> r)
forall (m :: * -> *) a. Monad m => a -> m a
return (((() -> s -> r) -> r) -> m ((() -> s -> r) -> r))
-> ((() -> s -> r) -> r) -> m ((() -> s -> r) -> r)
forall a b. (a -> b) -> a -> b
$ \f :: () -> s -> r
f -> () -> s -> r
f () s
s

instance {-# OVERLAPPABLE #-} (MonadState s m, MonadTrans t, Monad (t m))
    => MonadState s (t m) where
    get :: t m s
get = m s -> t m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
    put :: s -> t m ()
put = m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> (s -> m ()) -> s -> t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

-- ReaderT (IORef s) is better than StateT s for some applications,
-- since StateT loses its state after an exception such as ctrl-c.
instance MonadIO m => MonadState s (ReaderT (IORef s) m) where
    get :: ReaderT (IORef s) m s
get = ReaderT (IORef s) m (IORef s)
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT (IORef s) m (IORef s)
-> (IORef s -> ReaderT (IORef s) m s) -> ReaderT (IORef s) m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO s -> ReaderT (IORef s) m s
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO s -> ReaderT (IORef s) m s)
-> (IORef s -> IO s) -> IORef s -> ReaderT (IORef s) m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef s -> IO s
forall a. IORef a -> IO a
readIORef
    put :: s -> ReaderT (IORef s) m ()
put s :: s
s = ReaderT (IORef s) m (IORef s)
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT (IORef s) m (IORef s)
-> (IORef s -> ReaderT (IORef s) m ()) -> ReaderT (IORef s) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ReaderT (IORef s) m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (IORef s) m ())
-> (IORef s -> IO ()) -> IORef s -> ReaderT (IORef s) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IORef s -> s -> IO ()) -> s -> IORef s -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef s -> s -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef s
s

evalStateT' :: Monad m => s -> StateT s m a -> m a
evalStateT' :: s -> StateT s m a -> m a
evalStateT' s :: s
s f :: StateT s m a
f = ((a, s) -> a) -> m (a, s) -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, s) -> a
forall a b. (a, b) -> a
fst (m (a, s) -> m a) -> m (a, s) -> m a
forall a b. (a -> b) -> a -> b
$ StateT s m a -> s -> m (a, s)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m (a, s)
runStateT StateT s m a
f s
s

instance MonadException m => MonadException (StateT s m) where
    controlIO :: (RunIO (StateT s m) -> IO (StateT s m a)) -> StateT s m a
controlIO f :: RunIO (StateT s m) -> IO (StateT s m a)
f = (s -> m (a, s)) -> StateT s m a
forall (m :: * -> *) s a.
Monad m =>
(s -> m (a, s)) -> StateT s m a
makeStateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s :: s
s -> (RunIO m -> IO (m (a, s))) -> m (a, s)
forall (m :: * -> *) a.
MonadException m =>
(RunIO m -> IO (m a)) -> m a
controlIO ((RunIO m -> IO (m (a, s))) -> m (a, s))
-> (RunIO m -> IO (m (a, s))) -> m (a, s)
forall a b. (a -> b) -> a -> b
$ \run :: RunIO m
run ->
                    (StateT s m a -> m (a, s)) -> IO (StateT s m a) -> IO (m (a, s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StateT s m a -> s -> m (a, s)) -> s -> StateT s m a -> m (a, s)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT s m a -> s -> m (a, s)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m (a, s)
runStateT s
s) (IO (StateT s m a) -> IO (m (a, s)))
-> IO (StateT s m a) -> IO (m (a, s))
forall a b. (a -> b) -> a -> b
$ RunIO (StateT s m) -> IO (StateT s m a)
f (RunIO (StateT s m) -> IO (StateT s m a))
-> RunIO (StateT s m) -> IO (StateT s m a)
forall a b. (a -> b) -> a -> b
$ s -> RunIO m -> RunIO (StateT s m)
stateRunIO s
s RunIO m
run
      where
        stateRunIO :: s -> RunIO m -> RunIO (StateT s m)
        stateRunIO :: s -> RunIO m -> RunIO (StateT s m)
stateRunIO s :: s
s (RunIO run :: forall b. m b -> IO (m b)
run) = (forall b. StateT s m b -> IO (StateT s m b)) -> RunIO (StateT s m)
forall (m :: * -> *). (forall b. m b -> IO (m b)) -> RunIO m
RunIO (\m :: StateT s m b
m -> (m (b, s) -> StateT s m b) -> IO (m (b, s)) -> IO (StateT s m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((s -> m (b, s)) -> StateT s m b
forall (m :: * -> *) s a.
Monad m =>
(s -> m (a, s)) -> StateT s m a
makeStateT ((s -> m (b, s)) -> StateT s m b)
-> (m (b, s) -> s -> m (b, s)) -> m (b, s) -> StateT s m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (b, s) -> s -> m (b, s)
forall a b. a -> b -> a
const)
                                        (IO (m (b, s)) -> IO (StateT s m b))
-> IO (m (b, s)) -> IO (StateT s m b)
forall a b. (a -> b) -> a -> b
$ m (b, s) -> IO (m (b, s))
forall b. m b -> IO (m b)
run (StateT s m b -> s -> m (b, s)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m (a, s)
runStateT StateT s m b
m s
s))

orElse :: Monad m => MaybeT m a -> m a -> m a
orElse :: MaybeT m a -> m a -> m a
orElse (MaybeT f :: m (Maybe a)
f) g :: m a
g = m (Maybe a)
f m (Maybe a) -> (Maybe a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
g a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return