deepcontrol-0.3.2.0: DeepControl/Monad/Trans.hs
{-|
Module : DeepControl.Monad.Trans
Description : Enable deep level Monad-Transform programming.
Copyright : (c) Andy Gill 2001,
(c) Oregon Graduate Institute of Science and Technology, 2001,
(C) 2015 KONISHI Yohsuke
License : BSD-style (see the file LICENSE)
Maintainer : ocean0yohsuke@gmail.com
Stability : experimental
Portability : ---
This module enables you to program in Monad-Transformer style for more __deeper__ level than the usual @Control.Monad.Trans@ module expresses.
You would realize exactly what __/more deeper level/__ means by reading the example codes, which are attached on the page bottom.
Note: many instances for Level-4 and Level-5 haven't been written yet.
-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module DeepControl.Monad.Trans (
-- * MonadIO
MonadIO(..),
-- * MonadTrans
-- ** Level-1
MonadTrans(..),
MonadTransDown(..), M,
-- *** cover functions
MonadTransCover(..),
-- *** other
MonadTrans_(..),
-- ** Level-2
MonadTrans2(..),
MonadTrans2Down(..), M_, T_,
-- *** fold functions
MonadTransFold2(..),
-- *** cover functions
MonadTransCover2(..),
(|**|),
-- *** other
trans2, untrans2,
-- ** Level-3
MonadTrans3(..),
MonadTrans3Down(..), M__, T__,
-- *** fold functions
MonadTransFold3(..),
-- *** cover functions
MonadTransCover3(..),
(|***|), (|-**|), (|*-*|), (|**-|),
-- *** other
trans3, untrans3,
-- ** Level-4
MonadTrans4(..),
-- ** Level-5
MonadTrans5(..),
-- * Level-2 example
-- $Example_Level2
-- * Level-2 example2
-- $Example_Level2_cover
) where
import DeepControl.Applicative
import DeepControl.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (MonadTrans (..))
import qualified Control.Monad.List as L
import qualified Control.Monad.Trans.Maybe as M
import qualified Control.Monad.Except as E
import Control.Monad.Identity
----------------------------------------------------------------------
-- Level-1
class (Monad (TransDown t1), MonadTrans t1) => MonadTransDown t1 where
type TransDown t1 :: * -> *
type M t1 = TransDown t1
instance MonadTransDown L.ListT where
type TransDown L.ListT = []
instance MonadTransDown M.MaybeT where
type TransDown M.MaybeT = Maybe
instance MonadTransDown (E.ExceptT e) where
type TransDown (E.ExceptT e) = E.Except e
{-
class (MonadTrans t) => MonadTransFold t where
transfold :: (Monad m1) =>
m1 a -> t m1 a
-}
infixl 3 |*|
class (MonadTransDown t1) => MonadTransCover t1 where
(|*|) :: Monad m1 => (TransDown t1) a -> t1 m1 a
instance MonadTransCover L.ListT where
(|*|) = L.ListT . (*:)
instance MonadTransCover M.MaybeT where
(|*|) = M.MaybeT . (*:)
instance MonadTransCover (E.ExceptT e) where
(|*|) = E.ExceptT . (*:) . E.runExcept
-- | Required only for @'MonadTransFold2'@ and @'MonadTransFold3'@
class MonadTrans_ t1 where
trans :: (Monad m2) => m2 ((TransDown t1) a) -> t1 m2 a
untrans :: (Monad m2) => t1 m2 a -> m2 ((TransDown t1) a)
instance MonadTrans_ L.ListT where
trans = L.ListT
untrans = L.runListT
instance MonadTrans_ M.MaybeT where
trans = M.MaybeT
untrans = M.runMaybeT
instance MonadTrans_ (E.ExceptT e) where
untrans x = (E.ExceptT . Identity) |$> E.runExceptT x
trans x = E.ExceptT ((runIdentity . E.runExceptT) |$> x)
----------------------------------------------------------------------
-- Level-2
class MonadTrans2 t where
lift2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a
class (MonadTrans (Trans2Down t2), MonadTrans2 t2) => MonadTrans2Down t2 where
type Trans2Down t2 :: (* -> *) -> * -> *
type M_ t2 = TransDown (Trans2Down t2)
type T_ t2 = Trans2Down t2
-- |
--
-- Following property holds.
--
-- > untransfold2 . transfold2 == id
class (MonadTrans (T_ t), MonadTrans2 t) => MonadTransFold2 t where
transfold2 :: (Monad m1, Monad (t2 m1),
MonadTrans_ t2) =>
t m1 (TransDown t2) a -> (T_ t) (t2 m1) a
untransfold2 :: (Monad m1, Monad (t2 m1),
MonadTrans_ t2) =>
(T_ t) (t2 m1) a -> t m1 (TransDown t2) a
infixl 3 |-*|, |*-|, |**|
class (MonadTransCover (Trans2Down t2)) => MonadTransCover2 t2 where
(|-*|) :: (Monad m1, Monad2 m2) => (Trans2Down t2) m1 a -> t2 m1 m2 a
(|*-|) :: (Monad m1, Monad2 m2) => (Trans2Down t2) m2 a -> t2 m1 m2 a
(|**|) :: (Monad m1, Monad2 m2, MonadTransCover2 t2) =>
(M_ t2) a -> t2 m1 m2 a
(|**|) = (|*-|) . (|*|)
trans2 :: (Monad m1, Monad (t2 m1),
MonadTrans_ t2, MonadTrans_ t3) =>
m1 ((TransDown t2) ((TransDown t3) a)) -> t3 (t2 m1) a
trans2 = trans . trans
untrans2 :: (Monad m1, Monad (t2 m1),
MonadTrans_ t2, MonadTrans_ t3) =>
t3 (t2 m1) a -> m1 ((TransDown t2) ((TransDown t3) a))
untrans2 = untrans . untrans
----------------------------------------------------------------------
-- Level-3
class MonadTrans3 t where
lift3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a
class (MonadTrans2 (Trans3Down t3), MonadTrans3 t3) => MonadTrans3Down t3 where
type Trans3Down t3 :: (* -> *) -> (* -> *) -> * -> *
type M__ t3 = M_ (Trans3Down t3)
type T__ t3 = T_ (Trans3Down t3)
-- |
--
-- Following property holds.
--
-- > untransfold3 . transfold3 == id
class (MonadTrans (T__ t), MonadTrans3 t) => MonadTransFold3 t where
transfold3 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)),
MonadTrans t3, MonadTrans t2,
MonadTrans_ t2, MonadTrans_ t3) =>
t m1 (TransDown t2) (TransDown t3) a -> (T__ t) (t3 (t2 m1)) a
untransfold3 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)),
MonadTrans t3, MonadTrans t2,
MonadTrans_ t2, MonadTrans_ t3) =>
(T__ t) (t3 (t2 m1)) a -> t m1 (TransDown t2) (TransDown t3) a
infixl 3 |--*|, |-*-|, |*--|, |***|, |-**|, |*-*|, |**-|
class (MonadTransCover2 (Trans3Down t3)) => MonadTransCover3 t3 where
(|--*|) :: (Monad m1, Monad2 m2, Monad3 m3) => (Trans3Down t3) m1 m2 a -> t3 m1 m2 m3 a
(|-*-|) :: (Monad m1, Monad2 m2, Monad3 m3) => (Trans3Down t3) m1 m3 a -> t3 m1 m2 m3 a
(|*--|) :: (Monad m1, Monad2 m2, Monad3 m3) => (Trans3Down t3) m2 m3 a -> t3 m1 m2 m3 a
(|***|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) =>
(M__ t3) a -> t3 m1 m2 m3 a
(|***|) = (|*--|) . (|**|)
(|-**|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) =>
(T__ t3) m1 a -> t3 m1 m2 m3 a
(|-**|) = (|--*|) . (|-*|)
(|*-*|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) =>
(T__ t3) m2 a -> t3 m1 m2 m3 a
(|*-*|) = (|--*|) . (|*-|)
(|**-|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) =>
(T__ t3) m3 a -> t3 m1 m2 m3 a
(|**-|) = (|*--|) . (|*-|)
trans3 :: (Monad m1, Monad (t3 (t2 m1)), Monad (t2 m1),
MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4) =>
m1 ((TransDown t2) ((TransDown t3) ((TransDown t4) a))) -> t4 (t3 (t2 m1)) a
trans3 = trans2 . trans
untrans3 :: (Monad m1, Monad (t3 (t2 m1)), Monad (t2 m1),
MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4) =>
t4 (t3 (t2 m1)) a -> m1 ((TransDown t2) ((TransDown t3) ((TransDown t4) a)))
untrans3 = untrans2 . untrans
----------------------------------------------------------------------
-- Level-4
class MonadTrans4 t where
lift4 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 a))) -> t m1 m2 m3 m4 a
----------------------------------------------------------------------
-- Level-5
class MonadTrans5 t where
lift5 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => m1 (m2 (m3 (m4 (m5 a)))) -> t m1 m2 m3 m4 m5 a
----------------------------------------------------------------------
-- Examples
{- $Example_Level2
Here is a monad transformer example how to implement Ackermann function, improved to stop within a certain limit of time, with ReaderT2-IO-Maybe monad, a level-2 monad-transformation.
>import DeepControl.Applicative
>import DeepControl.Commutative (commute)
>import DeepControl.Monad ((>-))
>import DeepControl.Monad.Trans (lift2, transfold2, untransfold2)
>import DeepControl.Monad.Trans.Reader
>import Control.Monad.Trans.Maybe
>
>import System.Timeout (timeout)
>
>type TimeLimit = Int
>
>ackermannTimeLimit :: TimeLimit -> Int -> Int
> -> IO (Maybe Int) -- IO-Maybe Monad
>ackermannTimeLimit timelimit x y = timeout timelimit (ackermannIO x y)
> where
> ackermannIO :: Int -> Int -> IO Int
> ackermannIO 0 n = (*:) $ n + 1
> ackermannIO m n | m > 0 && n == 0 = ackermannIO (m-1) 1
> | m > 0 && n > 0 = ackermannIO m (n-1) >>= ackermannIO (m-1)
>
>ackermann :: Int -> Int ->
> ReaderT2 TimeLimit IO Maybe Int -- ReaderT2-IO-Maybe monad
>ackermann x y = do
> timelimit <- ask
> lift2 $ ackermannTimeLimit timelimit x y -- lift IO-Maybe function to ReaderT2-IO-Maybe function
>
>calc_ackermann :: TimeLimit -> Int -> Int -> IO (Maybe Int)
>calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT2 r timelimit
>
>-- λ> commute $ calc_ackermann 1000 |$> [0..4] |* 4
>-- [Just 5,Just 6,Just 11,Just 125,Nothing]
>
>ackermann' :: Int -> Int ->
> ReaderT TimeLimit (MaybeT IO) Int -- ReaderT-MaybeT-IO monad
>ackermann' x y = transfold2 $ ackermann x y -- You can get usual ReaderT-MaybeT-IO function from ReaderT2-IO-Maybe function
>
>ackermann'' :: Int -> Int ->
> ReaderT2 TimeLimit IO Maybe Int -- ReaderT2-IO-Maybe monad
>ackermann'' x y = untransfold2 $ ackermann' x y -- You can get ReaderT2-IO-Maybe function from usual ReaderT-MaybeT-IO function
-}
{- $Example_Level2_cover
Here is a monad transformer example showing how to use cover functions.
>import DeepControl.Applicative ((|$>))
>import DeepControl.Monad (Monad2)
>import DeepControl.Monad.Trans (lift, (|*|), (|-*|), (|*-|))
>import DeepControl.Monad.Trans.State
>import DeepControl.Monad.Trans.Writer
>
>tick :: State Int ()
>tick = modify (+1)
>
>tock :: StateT Int IO ()
>tock = do
> (|*|) tick :: (Monad m) => StateT Int m ()
> lift $ putStrLn "Tock!" :: (MonadTrans t) => t IO ()
>
>-- λ> runStateT tock 0
>-- Tock!
>-- ((),1)
>
>save :: StateT Int (Writer [Int]) ()
>save = do
> n <- get
> lift $ tell [n]
>
>program :: StateT2 Int IO (Writer [Int]) ()
>program = replicateM_ 4 $ do
> (|-*|) tock
> :: (Monad2 m) => StateT2 Int IO m ()
> (|*-|) save
> :: (Monad m) => StateT2 Int m (Writer [Int]) ()
>
>-- λ> execWriter |$> runStateT2 program 0
>-- Tock!
>-- Tock!
>-- Tock!
>-- Tock!
>-- [1,2,3,4]
-}