{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Trans.Loop (
LoopT(..),
stepLoopT,
continue,
exit,
continueWith,
exitWith,
foreach,
while,
doWhile,
once,
repeatLoopT,
iterateLoopT,
liftLocalLoopT,
) where
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad.Base (MonadBase(liftBase), liftBaseDefault)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Class (MonadTrans(lift))
newtype LoopT c e m a = LoopT
{ LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT :: forall r.
(c -> m r)
-> (e -> m r)
-> (a -> m r)
-> m r
}
instance Functor (LoopT c e m) where
fmap :: (a -> b) -> LoopT c e m a -> LoopT c e m b
fmap f :: a -> b
f m :: LoopT c e m a
m = (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b)
-> (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall a b. (a -> b) -> a -> b
$ \next :: c -> m r
next fin :: e -> m r
fin cont :: b -> m r
cont -> LoopT c e m a -> (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT c e m a
m c -> m r
next e -> m r
fin (b -> m r
cont (b -> m r) -> (a -> b) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
instance Applicative (LoopT c e m) where
pure :: a -> LoopT c e m a
pure a :: a
a = (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a)
-> (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall a b. (a -> b) -> a -> b
$ \_ _ cont :: a -> m r
cont -> a -> m r
cont a
a
f1 :: LoopT c e m (a -> b)
f1 <*> :: LoopT c e m (a -> b) -> LoopT c e m a -> LoopT c e m b
<*> f2 :: LoopT c e m a
f2 = (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b)
-> (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall a b. (a -> b) -> a -> b
$ \next :: c -> m r
next fin :: e -> m r
fin cont :: b -> m r
cont ->
LoopT c e m (a -> b)
-> (c -> m r) -> (e -> m r) -> ((a -> b) -> m r) -> m r
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT c e m (a -> b)
f1 c -> m r
next e -> m r
fin (((a -> b) -> m r) -> m r) -> ((a -> b) -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \f :: a -> b
f ->
LoopT c e m a -> (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT c e m a
f2 c -> m r
next e -> m r
fin (b -> m r
cont (b -> m r) -> (a -> b) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
instance Monad (LoopT c e m) where
return :: a -> LoopT c e m a
return a :: a
a = (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a)
-> (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall a b. (a -> b) -> a -> b
$ \_ _ cont :: a -> m r
cont -> a -> m r
cont a
a
m :: LoopT c e m a
m >>= :: LoopT c e m a -> (a -> LoopT c e m b) -> LoopT c e m b
>>= k :: a -> LoopT c e m b
k = (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b)
-> (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall a b. (a -> b) -> a -> b
$ \next :: c -> m r
next fin :: e -> m r
fin cont :: b -> m r
cont ->
LoopT c e m a -> (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT c e m a
m c -> m r
next e -> m r
fin ((a -> m r) -> m r) -> (a -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \a :: a
a ->
LoopT c e m b -> (c -> m r) -> (e -> m r) -> (b -> m r) -> m r
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT (a -> LoopT c e m b
k a
a) c -> m r
next e -> m r
fin b -> m r
cont
instance MonadTrans (LoopT c e) where
lift :: m a -> LoopT c e m a
lift m :: m a
m = (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a)
-> (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall a b. (a -> b) -> a -> b
$ \_ _ cont :: a -> m r
cont -> m a
m m a -> (a -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m r
cont
instance MonadIO m => MonadIO (LoopT c e m) where
liftIO :: IO a -> LoopT c e m a
liftIO = m a -> LoopT c e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> LoopT c e m a) -> (IO a -> m a) -> IO a -> LoopT c e 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
instance MonadBase b m => MonadBase b (LoopT c e m) where
liftBase :: b α -> LoopT c e m α
liftBase = b α -> LoopT c e m α
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) α.
(MonadTrans t, MonadBase b m) =>
b α -> t m α
liftBaseDefault
stepLoopT :: Monad m => LoopT c e m c -> (c -> m e) -> m e
stepLoopT :: LoopT c e m c -> (c -> m e) -> m e
stepLoopT body :: LoopT c e m c
body next :: c -> m e
next = LoopT c e m c -> (c -> m e) -> (e -> m e) -> (c -> m e) -> m e
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT c e m c
body c -> m e
next e -> m e
forall (m :: * -> *) a. Monad m => a -> m a
return c -> m e
next
continue :: LoopT () e m a
continue :: LoopT () e m a
continue = () -> LoopT () e m a
forall c e (m :: * -> *) a. c -> LoopT c e m a
continueWith ()
exit :: LoopT c () m a
exit :: LoopT c () m a
exit = () -> LoopT c () m a
forall e c (m :: * -> *) a. e -> LoopT c e m a
exitWith ()
continueWith :: c -> LoopT c e m a
continueWith :: c -> LoopT c e m a
continueWith c :: c
c = (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a)
-> (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall a b. (a -> b) -> a -> b
$ \next :: c -> m r
next _ _ -> c -> m r
next c
c
exitWith :: e -> LoopT c e m a
exitWith :: e -> LoopT c e m a
exitWith e :: e
e = (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a)
-> (forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
forall a b. (a -> b) -> a -> b
$ \_ fin :: e -> m r
fin _ -> e -> m r
fin e
e
foreach :: Monad m => [a] -> (a -> LoopT c () m c) -> m ()
foreach :: [a] -> (a -> LoopT c () m c) -> m ()
foreach list :: [a]
list body :: a -> LoopT c () m c
body = [a] -> m ()
loop [a]
list
where loop :: [a] -> m ()
loop [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop (x :: a
x:xs :: [a]
xs) = LoopT c () m c -> (c -> m ()) -> m ()
forall (m :: * -> *) c e.
Monad m =>
LoopT c e m c -> (c -> m e) -> m e
stepLoopT (a -> LoopT c () m c
body a
x) (\_ -> [a] -> m ()
loop [a]
xs)
while :: Monad m => m Bool -> LoopT c () m c -> m ()
while :: m Bool -> LoopT c () m c -> m ()
while cond :: m Bool
cond body :: LoopT c () m c
body = m ()
loop
where loop :: m ()
loop = do Bool
b <- m Bool
cond
if Bool
b then LoopT c () m c -> (c -> m ()) -> m ()
forall (m :: * -> *) c e.
Monad m =>
LoopT c e m c -> (c -> m e) -> m e
stepLoopT LoopT c () m c
body (\_ -> m ()
loop)
else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
doWhile :: Monad m => LoopT a a m a -> m Bool -> m a
doWhile :: LoopT a a m a -> m Bool -> m a
doWhile body :: LoopT a a m a
body cond :: m Bool
cond = m a
loop
where loop :: m a
loop = LoopT a a m a -> (a -> m a) -> m a
forall (m :: * -> *) c e.
Monad m =>
LoopT c e m c -> (c -> m e) -> m e
stepLoopT LoopT a a m a
body ((a -> m a) -> m a) -> (a -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> do
Bool
b <- m Bool
cond
if Bool
b then m a
loop
else a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
once :: Monad m => LoopT a a m a -> m a
once :: LoopT a a m a -> m a
once body :: LoopT a a m a
body = LoopT a a m a -> (a -> m a) -> (a -> m a) -> (a -> m a) -> m a
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT a a m a
body a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
repeatLoopT :: Monad m => LoopT c e m a -> m e
repeatLoopT :: LoopT c e m a -> m e
repeatLoopT body :: LoopT c e m a
body = m e
loop
where loop :: m e
loop = LoopT c e m a -> (c -> m e) -> (e -> m e) -> (a -> m e) -> m e
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT c e m a
body (\_ -> m e
loop) e -> m e
forall (m :: * -> *) a. Monad m => a -> m a
return (\_ -> m e
loop)
iterateLoopT :: Monad m => c -> (c -> LoopT c e m c) -> m e
iterateLoopT :: c -> (c -> LoopT c e m c) -> m e
iterateLoopT z :: c
z body :: c -> LoopT c e m c
body = c -> m e
loop c
z
where loop :: c -> m e
loop c :: c
c = LoopT c e m c -> (c -> m e) -> m e
forall (m :: * -> *) c e.
Monad m =>
LoopT c e m c -> (c -> m e) -> m e
stepLoopT (c -> LoopT c e m c
body c
c) c -> m e
loop
liftLocalLoopT :: Monad m => (forall a. m a -> m a) -> LoopT c e m b -> LoopT c e m b
liftLocalLoopT :: (forall a. m a -> m a) -> LoopT c e m b -> LoopT c e m b
liftLocalLoopT f :: forall a. m a -> m a
f cb :: LoopT c e m b
cb = (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall c e (m :: * -> *) a.
(forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r)
-> LoopT c e m a
LoopT ((forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b)
-> (forall r. (c -> m r) -> (e -> m r) -> (b -> m r) -> m r)
-> LoopT c e m b
forall a b. (a -> b) -> a -> b
$ \next :: c -> m r
next fin :: e -> m r
fin cont :: b -> m r
cont -> do
m r
m <- m (m r) -> m (m r)
forall a. m a -> m a
f (m (m r) -> m (m r)) -> m (m r) -> m (m r)
forall a b. (a -> b) -> a -> b
$ LoopT c e m b
-> (c -> m (m r)) -> (e -> m (m r)) -> (b -> m (m r)) -> m (m r)
forall c e (m :: * -> *) a.
LoopT c e m a
-> forall r. (c -> m r) -> (e -> m r) -> (a -> m r) -> m r
runLoopT LoopT c e m b
cb (m r -> m (m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r -> m (m r)) -> (c -> m r) -> c -> m (m r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> m r
next) (m r -> m (m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r -> m (m r)) -> (e -> m r) -> e -> m (m r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m r
fin) (m r -> m (m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r -> m (m r)) -> (b -> m r) -> b -> m (m r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> m r
cont)
m r
m