deepcontrol 0.3.3.0 → 0.4.1.0

raw patch · 18 files changed

+1058/−941 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• DeepControl/Applicative.hs +92/−28
• DeepControl/Commutative.hs +0/−2
• DeepControl/Monad.hs +11/−12
• DeepControl/Monad/Trans.hs +361/−61
• DeepControl/Monad/Trans/Except.hs +3/−3
• DeepControl/Monad/Trans/Identity.hs +277/−0
• DeepControl/Monad/Trans/RWS.hs +1/−174
• DeepControl/Monad/Trans/Reader.hs +2/−124
• DeepControl/Monad/Trans/State.hs +36/−143
• DeepControl/Monad/Trans/Writer.hs +2/−137
• README.md +31/−26
• deepcontrol.cabal +7/−6
• test/unit_Monad-Level1.hs +2/−2
• test/unit_Monad-Level2-2.hs +0/−87
• test/unit_Monad-Level2.hs +132/−121
• test/unit_Monad.hs +1/−2
• test/unit_MonadTrans-2.hs +85/−0
• test/unit_MonadTrans.hs +15/−13

@@ -5,7 +5,7 @@ License     : BSD-style (see the LICENSE file in the distribution) Maintainer  : ocean0yohsuke@gmail.com Stability   : experimental-Portability : ---+Portability : portable  This module enables you to program in applicative style for more __deeper__ level than the usual 'Control.Applicative' module expresses. You would soon realize exactly what __/more deeper level/__ means by reading the example codes in order, which are attached on the functions below.@@ -28,7 +28,7 @@      -- * Level-2     -- ** cover notation-    (**:), (*-), (-*),+    (**:), (-*),     -- ** bra-ket notation     (|$>>), (<<$|), (|*>>), (<<*|),     -- ** braket-cover notation@@ -40,7 +40,9 @@      -- * Level-3     -- ** cover notation-    (***:), (**-), (*-*), (-**), (--*), (-*-), (*--),+    (***:), +    (*-*), (-**), +    (--*),     -- ** bra-ket notation     (|$>>>), (<<<$|), (|*>>>), (<<<*|),     -- ** braket-cover notation@@ -56,6 +58,9 @@     -- * Level-4     -- ** cover notation     (****:), +    (---*),+    (--**), (-*-*), (*--*), +    (-***), (*-**), (**-*),     -- ** bra-ket notation     (|$>>>>), (<<<<$|), (|*>>>>), (<<<<*|),     -- ** sequnce notation@@ -64,6 +69,10 @@     -- * Level-5     -- ** cover notation     (*****:), +    (----*), +    (---**), (--*-*), (-*--*),+    (--***), (-*-**), (*--**), (*-*-*), (**--*),+    (-****), (*-***), (**-**), (***-*),     -- ** bra-ket notation     (|$>>>>>), (<<<<<$|), (|*>>>>>), (<<<<<*|),     -- ** sequnce notation@@ -189,16 +198,13 @@ -- Level-2 functions  infixl 6  **:-infixl 6  -*, *-+infixl 6  -* -- | Combination consisted of cover @'*:'@ twice, defined as @(**:) = (*:) . (*:)@. (**:) :: (Applicative f1, Applicative f2) => a -> f1 (f2 a) (**:) = (*:) . (*:) -- | Combination consisted of cover @'*:'@ and ket @'|$>'@, defined as @(-*) = ((*:)|$>)@. (-*) :: (Applicative f1, Applicative f2) => f1 a -> f1 (f2 a) (-*) = ((*:)|$>) --- | Alias for @'*:'@. -(*-) :: (Applicative f1, Applicative f2) => f2 a -> f1 (f2 a)-(*-) = (*:)  infixl 4  |$>> @@ -275,7 +281,7 @@ -- >>> [Just 1] <<$|(+)|*- Just 2  -- [Just 3] (|*-) :: (Applicative f1, Applicative f2) => f1 (f2 (a -> b)) -> f2 a -> f1 (f2 b)-f |*- x = f |*>> (*-) x+f |*- x = f |*>> (*:) x  -- | The auguments-flipped function for @'|-*'@. --@@ -385,21 +391,15 @@ -- Level-3 functions  infixl 6  ***:-infixl 6  -**, *-*, **-, --*, -*-, *-- (***:) :: (Applicative f1, Applicative f2, Applicative f3) => a -> f1 (f2 (f3 a)) (***:) = (*:) . (**:)+infixl 6  -**, *-*, --*+(--*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 a) -> f1 (f2 (f3 a))+(--*) = ((-*)|$>) (-**) :: (Applicative f1, Applicative f2, Applicative f3) => f1 a -> f1 (f2 (f3 a)) (-**) = ((**:)|$>)  (*-*) :: (Applicative f1, Applicative f2, Applicative f3) => f2 a -> f1 (f2 (f3 a))-(*-*) = (*:) . ((*:)|$>) -(**-) :: (Applicative f1, Applicative f2, Applicative f3) => f3 a -> f1 (f2 (f3 a))-(**-) = (**:)-(--*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 a) -> f1 (f2 (f3 a))-(--*) = ((*:)|$>>)-(-*-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f3 a) -> f1 (f2 (f3 a))-(-*-) = ((*:)|$>)-(*--) :: (Applicative f1, Applicative f2, Applicative f3) => f2 (f3 a) -> f1 (f2 (f3 a))-(*--) = (*:)+(*-*) = (--*) . (*:)   infixl 4  |$>>> (|$>>>) :: (Functor f1, Functor f2, Functor f3) => (a -> b) -> f1 (f2 (f3 a)) -> f1 (f2 (f3 b))@@ -426,13 +426,13 @@ (|*-*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f2 a -> f1 (f2 (f3 b)) f |*-* x = f |*>>> (*-*) x (|**-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f3 a -> f1 (f2 (f3 b))-f |**- x = f |*>>> (**-) x+f |**- x = f |*>>> (**:) x (|--*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f1 (f2 a) -> f1 (f2 (f3 b)) f |--* x = f |*>>> (--*) x (|*--) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f2 (f3 a) -> f1 (f2 (f3 b))-f |*-- x = f |*>>> (*--) x+f |*-- x = f |*>>> (*:) x (|-*-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f1 (f3 a) -> f1 (f2 (f3 b))-f |-*- x = f |*>>> (-*-) x+f |-*- x = f |*>>> (-*) x  (-**|) :: (Applicative f1, Applicative f2, Applicative f3) => f1 a -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b)) (-**|) = flip (|-**)@@ -455,13 +455,13 @@  infixl 5  *-->, -*->, --*>, **->, *-*>, -**> (*-->) :: (Applicative f1, Applicative f2, Applicative f3) => f2 (f3 a) -> f1 (f2 (f3 b)) -> f1 (f2 (f3 b))-a *--> x = (*--) a *>>> x+a *--> x = (*:) a *>>> x (-*->) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f3 a) -> f1 (f2 (f3 b)) -> f1 (f2 (f3 b))-a -*-> x = (-*-) a *>>> x+a -*-> x = (-*) a *>>> x (--*>) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 a) -> f1 (f2 (f3 b)) -> f1 (f2 (f3 b)) a --*> x = (--*) a *>>> x (**->) :: (Applicative f1, Applicative f2, Applicative f3) => f3 a -> f1 (f2 (f3 b)) -> f1 (f2 (f3 b))-a **-> x = (**-) a *>>> x+a **-> x = (**:) a *>>> x (*-*>) :: (Applicative f1, Applicative f2, Applicative f3) => f2 a -> f1 (f2 (f3 b)) -> f1 (f2 (f3 b)) a *-*> x = (*-*) a *>>> x (-**>) :: (Applicative f1, Applicative f2, Applicative f3) => f1 a -> f1 (f2 (f3 b)) -> f1 (f2 (f3 b))@@ -469,13 +469,13 @@  infixl 5  <*--, <-*-, <--*, <**-, <*-*, <-** (<*--) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 b)) -> f2 (f3 a) -> f1 (f2 (f3 b))-x <*-- a = x <<<* (*--) a+x <*-- a = x <<<* (*:) a (<-*-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 b)) -> f1 (f3 a) -> f1 (f2 (f3 b))-x <-*- a = x <<<* (-*-) a+x <-*- a = x <<<* (-*) a (<--*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 b)) -> f1 (f2 a) -> f1 (f2 (f3 b)) x <--* a = x <<<* (--*) a (<**-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 b)) -> f3 a -> f1 (f2 (f3 b))-x <**- a = x <<<* (**-) a +x <**- a = x <<<* (**:) a  (<*-*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 b)) -> f2 a -> f1 (f2 (f3 b)) x <*-* a = x <<<* (*-*) a (<-**) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 b)) -> f1 a -> f1 (f2 (f3 b))@@ -487,6 +487,23 @@ infixl 6  ****: (****:) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => a -> f1 (f2 (f3 (f4 a))) (****:) = (***:) . (*:)+infixl 6  ---*+(---*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 (f2 (f3 a)) -> f1 (f2 (f3 (f4 a)))+(---*) = ((--*)|$>)+infixl 6  --**, -*-*, *--*+(--**) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 (f2 a) -> f1 (f2 (f3 (f4 a)))+(--**) = (---*) . (--*) +(-*-*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 (f3 a) -> f1 (f2 (f3 (f4 a)))+(-*-*) = (---*) . (-*)+(*--*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f2 (f3 a) -> f1 (f2 (f3 (f4 a)))+(*--*) = (---*) . (*:)+infixl 6  -***, *-**, **-*+(-***) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 a -> f1 (f2 (f3 (f4 a)))+(-***) = ((***:)|$>) +(*-**) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f2 a -> f1 (f2 (f3 (f4 a)))+(*-**) = (---*) . (*-*) +(**-*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f3 a -> f1 (f2 (f3 (f4 a)))+(**-*) = (---*) . (**:)  infixl 4  |$>>>> (|$>>>>) :: (Functor f1, Functor f2, Functor f3, Functor f4) => (a -> b) -> f1 (f2 (f3 (f4 a))) -> f1 (f2 (f3 (f4 b)))@@ -510,8 +527,55 @@ -- Level-5 functions  infixl 6  *****:-(*****:) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => a -> f1 (f2 (f3 (f4 (f5 a))))+(*****:) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            a -> f1 (f2 (f3 (f4 (f5 a)))) (*****:) = (*:) . (****:)+infixl 6  ----*+(----*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f1 (f2 (f3 (f4 a))) -> f1 (f2 (f3 (f4 (f5 a))))+(----*) = ((---*)|$>)+infixl 6  ---**, --*-*, -*--*+(---**) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f1 (f2 (f3 a)) -> f1 (f2 (f3 (f4 (f5 a))))+(---**) = ((**:)|$>>>)+(--*-*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f1 (f2 (f4 a)) -> f1 (f2 (f3 (f4 (f5 a))))+(--*-*) = (----*) . (--*)+(-*--*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f1 (f3 (f4 a)) -> f1 (f2 (f3 (f4 (f5 a))))+(-*--*) = (----*) . (-*)+(*---*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f2 (f3 (f4 a)) -> f1 (f2 (f3 (f4 (f5 a))))+(*---*) = (----*) . (*:)+infixl 6  --***, -*-**, *--**, *-*-*, **--*+(--***) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f1 (f2 a) -> f1 (f2 (f3 (f4 (f5 a))))+(--***) = ((-***)|$>)+(-*-**) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f1 (f3 a) -> f1 (f2 (f3 (f4 (f5 a))))+(-*-**) = (---**) . (-*)+(*--**) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f2 (f3 a) -> f1 (f2 (f3 (f4 (f5 a))))+(*--**) = (---**) . (*:)+(*-*-*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f2 (f4 a) -> f1 (f2 (f3 (f4 (f5 a))))+(*-*-*) = (----*) . (*-*)+(**--*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f3 (f4 a) -> f1 (f2 (f3 (f4 (f5 a))))+(**--*) = (----*) . (**:)+infixl 6  -****, *-***, **-**, ***-*+(-****) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f1 a -> f1 (f2 (f3 (f4 (f5 a))))+(-****) = ((****:)|$>)+(*-***) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f2 a -> f1 (f2 (f3 (f4 (f5 a))))+(*-***) = (--***) . (*:)+(**-**) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f3 a -> f1 (f2 (f3 (f4 (f5 a))))+(**-**) = (---**) . (**:)+(***-*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => +            f4 a -> f1 (f2 (f3 (f4 (f5 a))))+(***-*) = (----*) . (***:)  infixl 4  |$>>>>> (|$>>>>>) :: (Functor f1, Functor f2, Functor f3, Functor f4, Functor f5) => (a -> b) -> f1 (f2 (f3 (f4 (f5 a)))) -> f1 (f2 (f3 (f4 (f5 b))))

@@ -9,8 +9,6 @@ Portability : ---  This module is made of @'Data.Traversable'@, distilling most function names polluted with action kind of concepts into crystalized(static) ones.-Another reason I put this module is for the case if GHC would parse @((->) r)@ as a data constructor someday.- -} module DeepControl.Commutative (     -- * Level-1

@@ -12,11 +12,10 @@  Note:  -    * Though this module substitutes for monad-transform consisted of elemental(without-lambda-expression) kind of monad, however, this module is unable to substitute for monad-transform consisted of complicated(tangled-with-lambda-expression) kind of monad at all.-      So this module does not thoroughly make mlt(monad-transformer-library) unnessasary. -      The range in which this module is helpful is confined to the range that single Monad or Monad with Monadx series (namely Monad2, Monad3, etc) defines.+    * This module never make mlt(monad-transformer-library) unnessasary. +      The range in which this module is helpful is regrettably confined to the range that the instances of deep Monads (namely Monad2, Monad3, etc) define.     -    * In my opinion the above problem is hard-wired with the ability of the compiler, that is to say GHC doesn't parse @(r->)@ or @((->) r)@ as a data constructor; +    * In my opinion this bad confinement is hard-wired with the ability of the compiler, that is to say GHC doesn't parse @(r->)@ or @((->) r)@ as a data constructor;        thus some fundamental expressions such as @(r->)|$>@ or @fmap (r->)@ are useless.       Theoretically it might be impossible though. @@ -164,13 +163,13 @@ m >-== k = (-*) m >>== k -- | Bind-cover function made of bind @'>>=='@ and cover @'*-'@, defined as @m >-== k = (*-) m >>== k@. (->==) :: (Monad m1, Monad2 m2) => m2 a -> (a -> m1 (m2 b)) -> m1 (m2 b)-m ->== k = (*-) m >>== k+m ->== k = (*:) m >>== k -- | Sequence-cover function made of sequence @'>>~'@ and cover @'-*'@, defined as @m >-~ k = (-*) m >>~ k@. (>-~) :: (Monad m1, Monad2 m2) => m1 a -> m1 (m2 b) -> m1 (m2 b) m >-~ k = (-*) m >>~ k -- | Sequence-cover function made of sequence @'>>~'@ and cover @'*-'@, defined as @m >-~ k = (*-) m >>~ k@. (->~) :: (Monad m1, Monad2 m2) => m2 a -> m1 (m2 b) -> m1 (m2 b)-m ->~ k = (*-) m >>~ k+m ->~ k = (*:) m >>~ k  instance Monad2 Maybe where     mmv >>== f = @@ -228,25 +227,25 @@ (->-==) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 a -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b)) m ->-== k = (*-*) m >>>== k (-->==) :: (Monad m1, Monad2 m2, Monad3 m3) => m3 a -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))-m -->== k = (**-) m >>>== k+m -->== k = (**:) m >>>== k (>>-==) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 a) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b)) m >>-== k = (--*) m >>>== k (->>==) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 (m3 a) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))-m ->>== k = (*--) m >>>== k+m ->>== k = (*:) m >>>== k (>->==) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m3 a) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))-m >->== k = (-*-) m >>>== k+m >->== k = (-*) m >>>== k (>--~) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 a -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b)) m >--~ k = (-**) m >>>~ k (->-~) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 a -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b)) m ->-~ k = (*-*) m >>>~ k (-->~) :: (Monad m1, Monad2 m2, Monad3 m3) => m3 a -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))-m -->~ k = (**-) m >>>~ k+m -->~ k = (**:) m >>>~ k (>>-~) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 a) -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b)) m >>-~ k = (--*) m >>>~ k (->>~) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 (m3 a) -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))-m ->>~ k = (*--) m >>>~ k+m ->>~ k = (*:) m >>>~ k (>->~) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m3 a) -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))-m >->~ k = (-*-) m >>>~ k+m >->~ k = (-*) m >>>~ k  instance Monad3 Maybe where     mmmv >>>== f = 

@@ -25,7 +25,10 @@      -- * MonadTrans     -- ** Level-1+    -- *** lift     MonadTrans(..), +    liftT, liftTT, liftTTT, liftTTTT, liftTTTTT,+    -- *** transdown     MonadTransDown(..), M,     -- *** cover       MonadTransCover(..),@@ -33,7 +36,10 @@     MonadTrans_(..),       -- ** Level-2+    -- *** lift     MonadTrans2(..), +    liftTT2, liftTTT2, liftTTTT2, liftTTTTT2,+    -- *** transdown     MonadTrans2Down(..), M_, T_,      -- *** fold      MonadTransFold2(..), @@ -44,21 +50,49 @@     trans2, untrans2,       -- ** Level-3+    -- *** lift     MonadTrans3(..), +    liftTT3, liftTTT3, liftTTTT3, liftTTTTT3,+    -- *** transdown     MonadTrans3Down(..), M__, T__,      -- *** fold      MonadTransFold3(..),      -- *** cover      MonadTransCover3(..),-    (|***|), (|-**|), (|*-*|), (|**-|),+    (|***|), +    (|-**|), (|*-*|), (|**-|),     -- *** other       trans3, untrans3,       -- ** Level-4+    -- *** lift     MonadTrans4(..),+    -- *** transdown+    MonadTrans4Down(..), M___, T___, T2__,+    -- *** fold +    MonadTransFold4(..), +    -- *** cover +    MonadTransCover4(..),+    (|****|), +    (|--**|), (|-*-*|), (|-**-|), (|*-*-|), (|**--|), (|*--*|),+    (|-***|), (|*-**|), (|**-*|), (|***-|), +    -- *** other  +    trans4, untrans4,       -- ** Level-5+    -- *** lift     MonadTrans5(..),+    -- *** transdown+    MonadTrans5Down(..), M____, T____, T2___, T3___,+    -- *** fold +    MonadTransFold5(..), +    -- *** cover +    MonadTransCover5(..),+    (|---**|), (|--*-*|), (|-*--*|), (|*---*|), (|*--*-|), (|*-*--|), (|**---|),+    (|--***|), (|-*-**|), (|*--**|), (|*-*-*|), (|**--*|), (|**-*-|), (|***--|),+    (|-****|), (|*-***|), (|**-**|), (|***-*|), (|****-|),+    -- *** other  +    trans5, untrans5,       -- * Level-2 example     -- $Example_Level2@@ -81,6 +115,34 @@ ---------------------------------------------------------------------- -- Level-1 +-- | Alias for @'lift'@+liftT :: (Monad m, MonadTrans t) => m a -> t m a +liftT = lift++liftTT+  :: (Monad m, Monad (t1 m), +      MonadTrans t, MonadTrans t1) =>+     m a -> t (t1 m) a+liftTT = liftT.liftT++liftTTT+  :: (Monad m, Monad (t1 (t2 m)), Monad (t2 m), MonadTrans t,+      MonadTrans t1, MonadTrans t2) =>+     m a -> t (t1 (t2 m)) a+liftTTT = liftT.liftT.liftT++liftTTTT+  :: (Monad m, Monad (t1 (t2 (t3 m))), Monad (t2 (t3 m)), Monad (t3 m), +      MonadTrans t, MonadTrans t1, MonadTrans t2, MonadTrans t3) =>+     m a -> t (t1 (t2 (t3 m))) a+liftTTTT = liftT.liftT.liftT.liftT++liftTTTTT+  :: (Monad m, Monad (t1 (t2 (t3 (t4 m)))), Monad (t2 (t3 (t4 m))), Monad (t3 (t4 m)), Monad (t4 m), +      MonadTrans t, MonadTrans t1, MonadTrans t2, MonadTrans t3, MonadTrans t4) =>+     m a -> t (t1 (t2 (t3 (t4 m)))) a+liftTTTTT = liftT.liftT.liftT.liftT.liftT+ class (Monad (TransDown t1), MonadTrans t1) => MonadTransDown t1 where     type TransDown t1 :: * -> * type M t1 = TransDown t1@@ -92,12 +154,6 @@ 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@@ -111,9 +167,9 @@     (|*|) = 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)+class MonadTrans_ t where+    trans :: (Monad m) => m ((TransDown t) a) -> t m a+    untrans :: (Monad m) => t m a -> m ((TransDown t) a)  instance MonadTrans_ L.ListT where     trans   = L.ListT@@ -129,13 +185,40 @@ -- Level-2  class MonadTrans2 t where-    lift2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a+    liftT2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a +liftTT2+  :: (Monad m1, Monad (t2 m1 m2), Monad2 m2,+      MonadTrans t1, MonadTrans2 t2) =>+     m1 (m2 a) -> t1 (t2 m1 m2) a+liftTT2 = liftT.liftT2++liftTTT2+  :: (Monad m1, Monad (t1 (t2 m1 m2)), Monad (t2 m1 m2), +      Monad2 m2, +      MonadTrans t, MonadTrans t1, MonadTrans2 t2) =>+     m1 (m2 a) -> t (t1 (t2 m1 m2)) a+liftTTT2 = liftT.liftT.liftT2++liftTTTT2+  :: (Monad m1, Monad (t1 (t1' (t2 m1 m2))), Monad (t1' (t2 m1 m2)), Monad (t2 m1 m2), +      Monad2 m2, +      MonadTrans t, MonadTrans t1, MonadTrans t1', MonadTrans2 t2) =>+     m1 (m2 a) -> t (t1 (t1' (t2 m1 m2))) a+liftTTTT2 = liftT.liftT.liftT.liftT2++liftTTTTT2+  :: (Monad m1, Monad (t1 (t1' (t1'' (t2 m1 m2)))), Monad (t1' (t1'' (t2 m1 m2))), Monad (t1'' (t2 m1 m2)), Monad (t2 m1 m2), +      Monad2 m2, +      MonadTrans t, MonadTrans t1, MonadTrans t1', MonadTrans t1'', MonadTrans2 t2) =>+     m1 (m2 a) -> t (t1 (t1' (t1'' (t2 m1 m2)))) a+liftTTTTT2 = liftT.liftT.liftT.liftT.liftT2+ class (MonadTrans (Trans2Down t2), MonadTrans2 t2) => MonadTrans2Down t2 where     type Trans2Down t2 :: (* -> *) -> * -> *-type M_ t2 = TransDown (Trans2Down t2) type T_ t2 = Trans2Down t2-+--type M_ t2 = TransDown (Trans2Down t2)+type M_ t2 = TransDown (T_ t2)  -- |  --@@ -160,25 +243,52 @@           (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 :: (Monad m, Monad (t1 m), +           MonadTrans_ t1, MonadTrans_ t2) =>+          m ((TransDown t1) ((TransDown t2) a)) -> t2 (t1 m) 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 :: (Monad m, Monad (t1 m), +             MonadTrans_ t1, MonadTrans_ t2) =>+            t2 (t1 m) a -> m ((TransDown t1) ((TransDown t2) 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+    liftT3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a +liftTT3+  :: (Monad m1, Monad (t3 m1 m2 m3), Monad2 m2, Monad3 m3,+      MonadTrans t, MonadTrans3 t3) =>+     m1 (m2 (m3 a)) -> t (t3 m1 m2 m3) a+liftTT3 = liftT.liftT3++liftTTT3+  :: (Monad m1, Monad (t1 (t3 m1 m2 m3)), Monad (t3 m1 m2 m3), Monad2 m2, Monad3 m3, +      MonadTrans t, MonadTrans t1, MonadTrans3 t3) =>+     m1 (m2 (m3 a)) -> t (t1 (t3 m1 m2 m3)) a+liftTTT3 = liftT.liftT.liftT3++liftTTTT3+  :: (Monad m1, Monad (t1 (t1' (t3 m1 m2 m3))), Monad (t1' (t3 m1 m2 m3)), Monad (t3 m1 m2 m3),+      Monad2 m2, Monad3 m3, +      MonadTrans t, MonadTrans t1, MonadTrans t1', MonadTrans3 t3) =>+     m1 (m2 (m3 a)) -> t (t1 (t1' (t3 m1 m2 m3))) a+liftTTTT3 = liftT.liftT.liftT.liftT3++liftTTTTT3+  :: (Monad m1, Monad (t1 (t1' (t1'' (t3 m1 m2 m3)))), Monad (t1' (t1'' (t3 m1 m2 m3))), Monad (t1'' (t3 m1 m2 m3)), Monad (t3 m1 m2 m3), +      Monad2 m2, Monad3 m3,+      MonadTrans t, MonadTrans t1, MonadTrans t1', MonadTrans t1'', MonadTrans3 t3) =>+     m1 (m2 (m3 a)) -> t (t1 (t1' (t1'' (t3 m1 m2 m3)))) a+liftTTTTT3 = liftT.liftT.liftT.liftT.liftT3+ class (MonadTrans2 (Trans3Down t3), MonadTrans3 t3) => MonadTrans3Down t3 where     type Trans3Down t3 :: (* -> *) -> (* -> *) -> * -> * type M__ t3 = M_ (Trans3Down t3) type T__ t3 = T_ (Trans3Down t3)+type T2_ t3 = Trans3Down t3  -- |  --@@ -187,24 +297,25 @@ -- > 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) => +                   MonadTrans t2, MonadTrans_ t2, +                   MonadTrans t3, 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) => +                     MonadTrans t2, MonadTrans_ t2, +                     MonadTrans t3, MonadTrans_ t3) =>                      (T__ t) (t3 (t2 m1)) a -> t m1 (TransDown t2) (TransDown t3) a -infixl 3  |--*|, |-*-|, |*--|, |***|, |-**|, |*-*|, |**-|-+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 +infixl 3  |***| (|***|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) =>             (M__ t3) a -> t3 m1 m2 m3 a-(|***|) = (|*--|) . (|**|)+infixl 3  |-**|, |*-*|, |**-|+(|***|) = (|--*|) . (|**|) (|-**|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) =>             (T__ t3) m1 a -> t3 m1 m2 m3 a (|-**|) = (|--*|) . (|-*|)@@ -213,40 +324,226 @@ (|*-*|) = (|--*|) . (|*-|) (|**-|) :: (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 :: (Monad m, Monad (t2 (t1 m)), Monad (t1 m),+           MonadTrans_ t1, MonadTrans_ t2, MonadTrans_ t3) =>+          m ((TransDown t1) ((TransDown t2) ((TransDown t3) a))) -> t3 (t2 (t1 m)) 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 :: (Monad m, Monad (t2 (t1 m)), Monad (t1 m),+             MonadTrans_ t1, MonadTrans_ t2, MonadTrans_ t3) =>+            t3 (t2 (t1 m)) a -> m ((TransDown t1) ((TransDown t2) ((TransDown t3) 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+    liftT4 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 a))) -> t m1 m2 m3 m4 a +class (MonadTrans3 (Trans4Down t4), MonadTrans4 t4) => MonadTrans4Down t4 where+    type Trans4Down t4 :: (* -> *) -> (* -> *) -> (* -> *) -> * -> *+type M___ t4 = M__ (Trans4Down t4)+type T___ t4 = T__ (Trans4Down t4)+type T2__ t4 = Trans3Down (Trans4Down t4)++-- | +--+-- Following property holds.+--+-- > untransfold4 . transfold4 == id+class (MonadTrans (T___ t), MonadTrans4 t) => MonadTransFold4 t where+    transfold4 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)), Monad (t4 (t3 (t2 m1))), +                   MonadTrans t2, MonadTrans_ t2, +                   MonadTrans t3, MonadTrans_ t3,+                   MonadTrans t4, MonadTrans_ t4) => +                  t m1 (TransDown t2) (TransDown t3) (TransDown t4) a -> (T___ t) (t4 (t3 (t2 m1))) a+    untransfold4 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)), Monad (t4 (t3 (t2 m1))), +                     MonadTrans t2, MonadTrans_ t2, +                     MonadTrans t3, MonadTrans_ t3,+                     MonadTrans t4, MonadTrans_ t4) => +                    (T___ t) (t4 (t3 (t2 m1))) a -> t m1 (TransDown t2) (TransDown t3) (TransDown t4) a++infixl 3  |---*|, |--*-|, |-*--|, |*---|+class (MonadTransCover3 (Trans4Down t4)) => MonadTransCover4 t4 where+    (|---*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => (Trans4Down t4) m1 m2 m3 a -> t4 m1 m2 m3 m4 a+    (|--*-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => (Trans4Down t4) m1 m2 m4 a -> t4 m1 m2 m3 m4 a+    (|-*--|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => (Trans4Down t4) m1 m3 m4 a -> t4 m1 m2 m3 m4 a+    (|*---|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => (Trans4Down t4) m2 m3 m4 a -> t4 m1 m2 m3 m4 a++infixl 3  |****|+(|****|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (M___ t4) a -> t4 m1 m2 m3 m4 a+(|****|) = (|---*|) . (|***|)+infixl 3  |--**|, |-*-*|, |-**-|, |*-*-|, |**--|, |*--*|+(|--**|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T2__ t4) m1 m2 a -> t4 m1 m2 m3 m4 a+(|--**|) = (|---*|) . (|--*|)+(|-*-*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T2__ t4) m1 m3 a -> t4 m1 m2 m3 m4 a+(|-*-*|) = (|---*|) . (|-*-|)+(|-**-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T2__ t4) m1 m4 a -> t4 m1 m2 m3 m4 a+(|-**-|) = (|--*-|) . (|-*-|)+(|*-*-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T2__ t4) m2 m4 a -> t4 m1 m2 m3 m4 a+(|*-*-|) = (|--*-|) . (|*--|)+(|**--|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T2__ t4) m3 m4 a -> t4 m1 m2 m3 m4 a+(|**--|) = (|-*--|) . (|*--|)+(|*--*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T2__ t4) m2 m3 a -> t4 m1 m2 m3 m4 a+(|*--*|) = (|---*|) . (|*--|)+infixl 3  |-***|, |*-**|, |**-*|, |***-| +(|-***|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T___ t4) m1 a -> t4 m1 m2 m3 m4 a+(|-***|) = (|---*|) . (|-**|)+(|*-**|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T___ t4) m2 a -> t4 m1 m2 m3 m4 a+(|*-**|) = (|---*|) . (|*-*|)+(|**-*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T___ t4) m3 a -> t4 m1 m2 m3 m4 a+(|**-*|) = (|---*|) . (|**-|)+(|***-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, MonadTransCover4 t4) => +            (T___ t4) m4 a -> t4 m1 m2 m3 m4 a+(|***-|) = (|--*-|) . (|**-|)++trans4 :: (Monad m, Monad (t3 (t2 (t1 m))), Monad (t2 (t1 m)), Monad (t1 m),+           MonadTrans_ t1, MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4) =>+          m ((TransDown t1) ((TransDown t2) ((TransDown t3) ((TransDown t4) a)))) -> t4 (t3 (t2 (t1 m))) a+trans4 = trans3 . trans+untrans4 :: (Monad m, Monad (t3 (t2 (t1 m))), Monad (t2 (t1 m)), Monad (t1 m),+             MonadTrans_ t1, MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4) =>+            t4 (t3 (t2 (t1 m))) a -> m ((TransDown t1) ((TransDown t2) ((TransDown t3) ((TransDown t4) a))))+untrans4 = untrans3 . untrans+ ---------------------------------------------------------------------- -- 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+    liftT5 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => m1 (m2 (m3 (m4 (m5 a)))) -> t m1 m2 m3 m4 m5 a +class (MonadTrans4 (Trans5Down t5), MonadTrans5 t5) => MonadTrans5Down t5 where+    type Trans5Down t5 :: (* -> *) -> (* -> *) -> (* -> *) -> (* -> *) -> * -> *+type M____ t5 = M___ (Trans5Down t5)+type T____ t5 = T___ (Trans5Down t5)+type T2___ t5 = T2__ (Trans5Down t5)+type T3___ t5 = Trans4Down (Trans5Down t5)++-- | +--+-- Following property holds.+--+-- > untransfold5 . transfold5 == id+class (MonadTrans (T____ t), MonadTrans5 t) => MonadTransFold5 t where+    transfold5 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)), Monad (t4 (t3 (t2 m1))), Monad (t5 (t4 (t3 (t2 m1)))), +                   MonadTrans t2, MonadTrans_ t2, +                   MonadTrans t3, MonadTrans_ t3,+                   MonadTrans t4, MonadTrans_ t4,+                   MonadTrans t5, MonadTrans_ t5) => +                  t m1 (TransDown t2) (TransDown t3) (TransDown t4) (TransDown t5) a -> (T____ t) (t5 (t4 (t3 (t2 m1)))) a+    untransfold5 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)), Monad (t4 (t3 (t2 m1))), Monad (t5 (t4 (t3 (t2 m1)))), +                     MonadTrans t2, MonadTrans_ t2, +                     MonadTrans t3, MonadTrans_ t3,+                     MonadTrans t4, MonadTrans_ t4,+                     MonadTrans t5, MonadTrans_ t5) => +                    (T____ t) (t5 (t4 (t3 (t2 m1)))) a -> t m1 (TransDown t2) (TransDown t3) (TransDown t4) (TransDown t5) a++infixl 3  |----*|, |---*-|, |--*--|, |-*---|, |*----|+class (MonadTransCover4 (Trans5Down t5)) => MonadTransCover5 t5 where+    (|----*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => (Trans5Down t5) m1 m2 m3 m4 a -> t5 m1 m2 m3 m4 m5 a+    (|---*-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => (Trans5Down t5) m1 m2 m3 m5 a -> t5 m1 m2 m3 m4 m5 a+    (|--*--|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => (Trans5Down t5) m1 m2 m4 m5 a -> t5 m1 m2 m3 m4 m5 a+    (|-*---|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => (Trans5Down t5) m1 m3 m4 m5 a -> t5 m1 m2 m3 m4 m5 a+    (|*----|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => (Trans5Down t5) m2 m3 m4 m5 a -> t5 m1 m2 m3 m4 m5 a++infixl 3  |*****|+(|*****|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (M____ t5) a -> t5 m1 m2 m3 m4 m5 a+(|*****|) = (|----*|) . (|****|)+infixl 3  |---**|, |--*-*|, |-*--*|, |*---*|, |*--*-|, |*-*--|, |**---|+(|---**|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T3___ t5) m1 m2 m3 a -> t5 m1 m2 m3 m4 m5 a+(|---**|) = (|----*|) . (|---*|)+(|--*-*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T3___ t5) m1 m2 m4 a -> t5 m1 m2 m3 m4 m5 a+(|--*-*|) = (|----*|) . (|--*-|)+(|-*--*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T3___ t5) m1 m3 m4 a -> t5 m1 m2 m3 m4 m5 a+(|-*--*|) = (|----*|) . (|-*--|)+(|*---*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T3___ t5) m2 m3 m4 a -> t5 m1 m2 m3 m4 m5 a+(|*---*|) = (|----*|) . (|*---|)+(|*--*-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T3___ t5) m2 m3 m5 a -> t5 m1 m2 m3 m4 m5 a+(|*--*-|) = (|---*-|) . (|*---|)+(|*-*--|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T3___ t5) m2 m4 m5 a -> t5 m1 m2 m3 m4 m5 a+(|*-*--|) = (|--*--|) . (|*---|)+(|**---|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T3___ t5) m3 m4 m5 a -> t5 m1 m2 m3 m4 m5 a+(|**---|) = (|-*---|) . (|*---|)+infixl 3  |--***|, |-*-**|, |*--**|, |*-*-*|, |**--*|, |**-*-|, |***--|+(|--***|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T2___ t5) m1 m2 a -> t5 m1 m2 m3 m4 m5 a+(|--***|) = (|----*|) . (|--**|)+(|-*-**|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T2___ t5) m1 m3 a -> t5 m1 m2 m3 m4 m5 a+(|-*-**|) = (|----*|) . (|-*-*|)+(|*--**|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T2___ t5) m2 m3 a -> t5 m1 m2 m3 m4 m5 a+(|*--**|) = (|----*|) . (|*--*|)+(|*-*-*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T2___ t5) m2 m4 a -> t5 m1 m2 m3 m4 m5 a+(|*-*-*|) = (|----*|) . (|*-*-|)+(|**--*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T2___ t5) m3 m4 a -> t5 m1 m2 m3 m4 m5 a+(|**--*|) = (|----*|) . (|**--|)+(|**-*-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T2___ t5) m3 m5 a -> t5 m1 m2 m3 m4 m5 a+(|**-*-|) = (|---*-|) . (|**--|)+(|***--|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T2___ t5) m4 m5 a -> t5 m1 m2 m3 m4 m5 a+(|***--|) = (|--*--|) . (|**--|)+infixl 3  |-****|, |*-***|, |**-**|, |***-*|, |****-|+(|-****|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T____ t5) m1 a -> t5 m1 m2 m3 m4 m5 a+(|-****|) = (|----*|) . (|-***|)+(|*-***|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T____ t5) m2 a -> t5 m1 m2 m3 m4 m5 a+(|*-***|) = (|----*|) . (|*-**|)+(|**-**|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T____ t5) m3 a -> t5 m1 m2 m3 m4 m5 a+(|**-**|) = (|----*|) . (|**-*|)+(|***-*|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T____ t5) m4 a -> t5 m1 m2 m3 m4 m5 a+(|***-*|) = (|----*|) . (|***-|)+(|****-|) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5, MonadTransCover5 t5) => +            (T____ t5) m5 a -> t5 m1 m2 m3 m4 m5 a+(|****-|) = (|---*-|) . (|***-|)++trans5 :: (Monad m, Monad (t4 (t3 (t2 (t1 m)))), Monad (t3 (t2 (t1 m))), Monad (t2 (t1 m)), Monad (t1 m),+           MonadTrans_ t1, MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4, MonadTrans_ t5) =>+          m ((TransDown t1) ((TransDown t2) ((TransDown t3) ((TransDown t4) ((TransDown t5) a))))) -> t5 (t4 (t3 (t2 (t1 m)))) a+trans5 = trans4 . trans+untrans5 :: (Monad m, Monad (t4 (t3 (t2 (t1 m)))), Monad (t3 (t2 (t1 m))), Monad (t2 (t1 m)), Monad (t1 m),+             MonadTrans_ t1, MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4, MonadTrans_ t5) =>+            t5 (t4 (t3 (t2 (t1 m)))) a -> m ((TransDown t1) ((TransDown t2) ((TransDown t3) ((TransDown t4) ((TransDown t5) a)))))+untrans5 = untrans4 . untrans++ ---------------------------------------------------------------------- -- 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.+Here is a monad transformer example how to implement Ackermann function, improved to stop within a certain limit of time, with ReaderT-IdentityT2-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.Morph ((|>|))+>import DeepControl.Monad.Trans (liftTT2, transfold2, untransfold2)+>import DeepControl.Monad.Trans.Identity >import DeepControl.Monad.Trans.Reader >import Control.Monad.Trans.Maybe >@@ -254,8 +551,8 @@ > >type TimeLimit = Int >->ackermannTimeLimit :: TimeLimit -> Int -> Int->                      -> IO (Maybe Int)             -- IO-Maybe Monad+>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@@ -264,24 +561,25 @@ >                    | m > 0 && n > 0  = ackermannIO m (n-1) >>= ackermannIO (m-1) >  >ackermann :: Int -> Int -> ->               ReaderT2 TimeLimit IO Maybe Int      -- ReaderT2-IO-Maybe monad+>             ReaderT TimeLimit (IdentityT2 IO Maybe) Int -- ReaderT-IdentityT2-IO-Maybe monad >ackermann x y = do >    timelimit <- ask->    lift2 $ ackermannTimeLimit timelimit x y        -- lift IO-Maybe function to ReaderT2-IO-Maybe function+>    liftTT2 $ ackermannTimeLimit timelimit x y           -- lift IO-Maybe function to ReaderT-IdentityT2-IO-Maybe function > >calc_ackermann :: TimeLimit -> Int -> Int -> IO (Maybe Int)->calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT2 r timelimit+>calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT r timelimit+>                                             >- runIdentityT2 > >-- λ> 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+>              ReaderT TimeLimit (MaybeT IO) Int                -- ReaderT-MaybeT-IO monad+>ackermann' x y = (runIdentityT . transfold2) |>| ackermann x y -- You can get usual ReaderT-MaybeT-IO function from ReaderT-IdentityT2-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+>               ReaderT TimeLimit (IdentityT2 IO Maybe) Int      -- ReaderT-IdentityT2-IO-Maybe monad+>ackermann'' x y = (untransfold2 . IdentityT) |>| ackermann' x y -- You can get ReaderT-IdentityT2-IO-Maybe function from usual ReaderT-MaybeT-IO function -}  {- $Example_Level2_cover@@ -289,35 +587,37 @@  >import DeepControl.Applicative ((|$>)) >import DeepControl.Monad (Monad2)->import DeepControl.Monad.Trans (lift, (|*|), (|-*|), (|*-|))->import DeepControl.Monad.Trans.State+>import DeepControl.Monad.Morph ((|>|))+>import DeepControl.Monad.Trans (liftT, (|*|), (|-*|), (|*-|)) >import DeepControl.Monad.Trans.Writer+>import DeepControl.Monad.Trans.Identity+>import DeepControl.Monad.Trans.State > >tick :: State Int () >tick = modify (+1) >->tock                        ::                   StateT Int IO ()+>tock                         ::                   StateT Int IO () >tock = do->    (|*|) tick              :: (Monad      m) => StateT Int m  ()->    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()+>    (|*|) tick               :: (Monad      m) => StateT Int m  ()+>    liftT $ putStrLn "Tock!" :: (MonadTrans t) => t          IO () > >-- λ> runStateT tock 0 >-- Tock! >-- ((),1) >->save :: StateT Int (Writer [Int]) ()+>save    :: StateT Int (Writer [Int]) () >save = do >    n <- get->    lift $ tell [n]+>    liftT $ tell [n] >->program ::               StateT2 Int IO (Writer [Int]) ()+>program ::               StateT Int (IdentityT2 IO (Writer [Int])) () >program = replicateM_ 4 $ do->    (|-*|) tock->        :: (Monad2 m) => StateT2 Int IO m              ()->    (|*-|) save->        :: (Monad  m) => StateT2 Int m  (Writer [Int]) ()+>    ((|-*|).liftT) |>| tock+>        :: (Monad2 m) => StateT Int (IdentityT2 IO m             ) ()+>    ((|*-|).liftT) |>| save+>        :: (Monad  m) => StateT Int (IdentityT2 m  (Writer [Int])) () >->-- λ> execWriter |$> runStateT2 program 0+>-- λ> execWriter |$> runIdentityT2 (runStateT program 0) >-- Tock! >-- Tock! >-- Tock!

@@ -1,5 +1,5 @@ {-|-Module      : DeepControl.Monad.Except+Module      : DeepControl.Monad.Trans.Except Description : Extension for mtl's Contrl.Monad.Except. Copyright   : (C) 2013 Ross Paterson,               (C) 2015 KONISHI Yohsuke @@ -8,7 +8,7 @@ Stability   : experimental Portability : --- -This module extended RWS Monad of mtl(monad-transformer-library).+This module extended Except monad of mtl(monad-transformer-library). -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}@@ -45,7 +45,7 @@ -- Level-1  instance Commutative (Except e) where-    commute x = ExceptT . Identity |$> commute (runExcept $ x)+    commute x = ExceptT . Identity |$> commute (runExcept x)  instance Monad2 (Except e) where     m >>== f = (ExceptT . Identity |$>) $ (runExcept |$> m) >>== runExcept |$>> f

@@ -0,0 +1,277 @@+{-|+Module      : DeepControl.Monad.Trans.Identity+Description : ---+Copyright   : (c) 2007 Magnus Therning,+              (C) 2015 KONISHI Yohsuke+License     : BSD-style (see the file LICENSE)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---+++-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+module DeepControl.Monad.Trans.Identity (+    module Data.Functor.Identity,+    module Control.Monad.Trans.Identity,++    -- * Level-2+    IdentityT2(..),+    -- ** lift functions+    mapIdentityT2, liftCallCC2, liftCatch2,++    -- * Level-3+    IdentityT3(..),+    -- ** lift functions+    mapIdentityT3, liftCallCC3, liftCatch3,++    -- * Level-4+    IdentityT4(..),+    -- ** lift functions+    mapIdentityT4, liftCallCC4, liftCatch4,++    -- * Level-5+    IdentityT5(..),+    -- ** lift functions+    mapIdentityT5, liftCallCC5, liftCatch5,++    ) where ++import DeepControl.Applicative+import DeepControl.Commutative+import DeepControl.Monad+import DeepControl.Monad.Trans+import DeepControl.Monad.Signatures++import Data.Functor.Identity+import Control.Monad.Trans.Identity++----------------------------------------------------------------------+-- Level-1++instance (Commutative f) => Commutative (IdentityT f) where+    commute = (IdentityT|$>) . commute . runIdentityT++instance MonadTransDown IdentityT where+    type TransDown IdentityT = Identity++instance MonadTransCover IdentityT where+    (|*|) = IdentityT . (*:) . runIdentity++----------------------------------------------------------------------+-- Level-2++newtype IdentityT2 f1 f2 a = IdentityT2 { runIdentityT2 :: f1 (f2 a) }+    deriving (Functor, Eq, Ord, Read, Show, Foldable, Traversable)++instance (Commutative f1, Commutative f2) => Commutative (IdentityT2 f1 f2) where+    commute = (IdentityT2|$>) . float2 . runIdentityT2++instance (Applicative m1, Applicative m2) => Applicative (IdentityT2 m1 m2) where+    pure x = IdentityT2 $ (**:) x+    (<*>) = lift2IdentityT2 (|*>>)+instance (Monad m1, Monad2 m2) => Monad (IdentityT2 m1 m2) where+    return = IdentityT2 . (**:)+    m >>= f = IdentityT2 $ runIdentityT2 m >>== (f >-> runIdentityT2)++instance (Alternative m1, Alternative m2) => Alternative (IdentityT2 m1 m2) where+    empty = IdentityT2 empty+    (<|>) = lift2IdentityT2 (<|>)+instance (MonadPlus m1, Alternative m2, Monad2 m2) => MonadPlus (IdentityT2 m1 m2) where+    mzero = IdentityT2 mzero+    mplus = lift2IdentityT2 mplus++instance MonadTrans2 IdentityT2 where+    liftT2 = IdentityT2+instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (IdentityT2 m1 m2) where+    liftIO = liftT2 . (-*) . liftIO++lift2IdentityT2 ::+    (m1 (m2 a) -> n1 (n2 b) -> p1 (p2 c)) -> IdentityT2 m1 m2 a -> IdentityT2 n1 n2 b -> IdentityT2 p1 p2 c+lift2IdentityT2 f a b = IdentityT2 (f (runIdentityT2 a) (runIdentityT2 b))++mapIdentityT2 :: (m1 (m2 a) -> n1 (n2 b)) -> IdentityT2 m1 m2 a -> IdentityT2 n1 n2 b+mapIdentityT2 f = IdentityT2 . f . runIdentityT2++liftCallCC2 :: CallCC2 m1 m2 a b -> CallCC (IdentityT2 m1 m2) a b+liftCallCC2 callCC f = IdentityT2 $ callCC $ \c -> runIdentityT2 $ (c >-> IdentityT2) >- f++liftCatch2 :: Catch2 e m1 m2 a -> Catch e (IdentityT2 m1 m2) a+liftCatch2 catch m h = IdentityT2 $ (runIdentityT2 m) `catch` (h >-> runIdentityT2)++instance MonadTrans2Down IdentityT2 where+    type Trans2Down IdentityT2 = IdentityT++instance MonadTransFold2 IdentityT2 where+    transfold2 (IdentityT2 x) = IdentityT $ trans x+    untransfold2 (IdentityT x) = IdentityT2 $ untrans x++instance MonadTransCover2 IdentityT2 where+    (|-*|) = IdentityT2 . (-*) . runIdentityT+    (|*-|) = IdentityT2 . (*:) . runIdentityT++----------------------------------------------------------------------+-- Level-3++newtype IdentityT3 f1 f2 f3 a = IdentityT3 { runIdentityT3 :: f1 (f2 (f3 a)) }+    deriving (Functor, Eq, Ord, Read, Show, Foldable, Traversable)++instance (Commutative f1, Commutative f2, Commutative f3) => Commutative (IdentityT3 f1 f2 f3) where+    commute = (IdentityT3|$>) . float3 . runIdentityT3++instance (Applicative m1, Applicative m2, Applicative m3) => Applicative (IdentityT3 m1 m2 m3) where+    pure x = IdentityT3 $ (***:) x+    (<*>) = lift3IdentityT3 (|*>>>)+instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (IdentityT3 m1 m2 m3) where+    return = IdentityT3 . (***:)+    m >>= f = IdentityT3 $ runIdentityT3 m >>>== (f >-> runIdentityT3)++instance (Alternative m1, Alternative m2, Alternative m3) => Alternative (IdentityT3 m1 m2 m3) where+    empty = IdentityT3 empty+    (<|>) = lift3IdentityT3 (<|>)+instance (MonadPlus m1, Alternative m2, Monad2 m2, Alternative m3, Monad3 m3) => MonadPlus (IdentityT3 m1 m2 m3) where+    mzero = IdentityT3 mzero+    mplus = lift3IdentityT3 mplus++instance MonadTrans3 IdentityT3 where+    liftT3 = IdentityT3+instance (MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (IdentityT3 m1 m2 m3) where+    liftIO = liftT3 . (-**) . liftIO++lift3IdentityT3 ::+    (m1 (m2 (m3 a)) -> n1 (n2 (n3 b)) -> p1 (p2 (p3 c))) -> IdentityT3 m1 m2 m3 a -> IdentityT3 n1 n2 n3 b -> IdentityT3 p1 p2 p3 c+lift3IdentityT3 f a b = IdentityT3 (f (runIdentityT3 a) (runIdentityT3 b))++mapIdentityT3 :: (m1 (m2 (m3 a)) -> n1 (n2 (n3 b))) -> IdentityT3 m1 m2 m3 a -> IdentityT3 n1 n2 n3 b+mapIdentityT3 f = IdentityT3 . f . runIdentityT3++liftCallCC3 :: CallCC3 m1 m2 m3 a b -> CallCC (IdentityT3 m1 m2 m3) a b+liftCallCC3 callCC f = IdentityT3 $ callCC $ \c -> runIdentityT3 $ (c >-> IdentityT3) >- f++liftCatch3 :: Catch3 e m1 m2 m3 a -> Catch e (IdentityT3 m1 m2 m3) a+liftCatch3 catch m h = IdentityT3 $ (runIdentityT3 m) `catch` (h >-> runIdentityT3)++instance MonadTrans3Down IdentityT3 where+    type Trans3Down IdentityT3 = IdentityT2++instance MonadTransFold3 IdentityT3 where+    transfold3 (IdentityT3 x) = IdentityT $ trans2 x+    untransfold3 (IdentityT x) = IdentityT3 $ untrans2 x++instance MonadTransCover3 IdentityT3 where+    (|--*|) = IdentityT3 . (--*) . runIdentityT2+    (|-*-|) = IdentityT3 . (-*) . runIdentityT2+    (|*--|) = IdentityT3 . (*:) . runIdentityT2++----------------------------------------------------------------------+-- Level-4++newtype IdentityT4 f1 f2 f3 f4 a = IdentityT4 { runIdentityT4 :: f1 (f2 (f3 (f4 a))) }+    deriving (Functor, Eq, Ord, Read, Show, Foldable, Traversable)++instance (Commutative f1, Commutative f2, Commutative f3, Commutative f4) => Commutative (IdentityT4 f1 f2 f3 f4) where+    commute = (IdentityT4|$>) . float4 . runIdentityT4++instance (Applicative m1, Applicative m2, Applicative m3, Applicative m4) => Applicative (IdentityT4 m1 m2 m3 m4) where+    pure x = IdentityT4 $ (****:) x+    (<*>) = lift4IdentityT4 (|*>>>>)+instance (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => Monad (IdentityT4 m1 m2 m3 m4) where+    return = IdentityT4 . (****:)+    m >>= f = IdentityT4 $ runIdentityT4 m >>>>== (f >-> runIdentityT4)++instance (Alternative m1, Alternative m2, Alternative m3, Alternative m4) => Alternative (IdentityT4 m1 m2 m3 m4) where+    empty = IdentityT4 empty+    (<|>) = lift4IdentityT4 (<|>)+instance (MonadPlus m1, Alternative m2, Monad2 m2, Alternative m3, Monad3 m3, Alternative m4, Monad4 m4) => MonadPlus (IdentityT4 m1 m2 m3 m4) where+    mzero = IdentityT4 mzero+    mplus = lift4IdentityT4 mplus++instance MonadTrans4 IdentityT4 where+    liftT4 = IdentityT4+instance (MonadIO m1, Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => MonadIO (IdentityT4 m1 m2 m3 m4) where+    liftIO = liftT4 . (-***) . liftIO++lift4IdentityT4 ::+    (m1 (m2 (m3 (m4 a))) -> n1 (n2 (n3 (n4 b))) -> p1 (p2 (p3 (p4 c)))) -> IdentityT4 m1 m2 m3 m4 a -> IdentityT4 n1 n2 n3 n4 b -> IdentityT4 p1 p2 p3 p4 c+lift4IdentityT4 f a b = IdentityT4 (f (runIdentityT4 a) (runIdentityT4 b))++mapIdentityT4 :: (m1 (m2 (m3 (m4 a))) -> n1 (n2 (n3 (n4 b)))) -> IdentityT4 m1 m2 m3 m4 a -> IdentityT4 n1 n2 n3 n4 b+mapIdentityT4 f = IdentityT4 . f . runIdentityT4++liftCallCC4 :: CallCC4 m1 m2 m3 m4 a b -> CallCC (IdentityT4 m1 m2 m3 m4) a b+liftCallCC4 callCC f = IdentityT4 $ callCC $ \c -> runIdentityT4 $ (c >-> IdentityT4) >- f++liftCatch4 :: Catch4 e m1 m2 m3 m4 a -> Catch e (IdentityT4 m1 m2 m3 m4) a+liftCatch4 catch m h = IdentityT4 $ (runIdentityT4 m) `catch` (h >-> runIdentityT4)++instance MonadTrans4Down IdentityT4 where+    type Trans4Down IdentityT4 = IdentityT3++instance MonadTransFold4 IdentityT4 where+    transfold4 (IdentityT4 x) = IdentityT $ trans3 x+    untransfold4 (IdentityT x) = IdentityT4 $ untrans3 x++instance MonadTransCover4 IdentityT4 where+    (|---*|) = IdentityT4 . (---*) . runIdentityT3+    (|--*-|) = IdentityT4 . (--*) . runIdentityT3+    (|-*--|) = IdentityT4 . (-*) . runIdentityT3+    (|*---|) = IdentityT4 . (*:) . runIdentityT3++----------------------------------------------------------------------+-- Level-5++newtype IdentityT5 f1 f2 f3 f4 f5 a = IdentityT5 { runIdentityT5 :: f1 (f2 (f3 (f4 (f5 a)))) }+    deriving (Functor, Eq, Ord, Read, Show, Foldable, Traversable)++instance (Commutative f1, Commutative f2, Commutative f3, Commutative f4, Commutative f5) => Commutative (IdentityT5 f1 f2 f3 f4 f5) where+    commute = (IdentityT5|$>) . float5 . runIdentityT5++instance (Applicative m1, Applicative m2, Applicative m3, Applicative m4, Applicative m5) => Applicative (IdentityT5 m1 m2 m3 m4 m5) where+    pure x = IdentityT5 $ (*****:) x+    (<*>) = lift5IdentityT5 (|*>>>>>)+instance (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => Monad (IdentityT5 m1 m2 m3 m4 m5) where+    return = IdentityT5 . (*****:)+    m >>= f = IdentityT5 $ runIdentityT5 m >>>>>== (f >-> runIdentityT5)++instance (Alternative m1, Alternative m2, Alternative m3, Alternative m4, Alternative m5) => Alternative (IdentityT5 m1 m2 m3 m4 m5) where+    empty = IdentityT5 empty+    (<|>) = lift5IdentityT5 (<|>)+instance (MonadPlus m1, Alternative m2, Monad2 m2, Alternative m3, Monad3 m3, Alternative m4, Monad4 m4, Alternative m5, Monad5 m5) => MonadPlus (IdentityT5 m1 m2 m3 m4 m5) where+    mzero = IdentityT5 mzero+    mplus = lift5IdentityT5 mplus++instance MonadTrans5 IdentityT5 where+    liftT5 = IdentityT5+instance (MonadIO m1, Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => MonadIO (IdentityT5 m1 m2 m3 m4 m5) where+    liftIO = liftT5 . (-****) . liftIO++lift5IdentityT5 ::+    (m1 (m2 (m3 (m4 (m5 a)))) -> n1 (n2 (n3 (n4 (n5 b)))) -> p1 (p2 (p3 (p4 (p5 c))))) -> IdentityT5 m1 m2 m3 m4 m5 a -> IdentityT5 n1 n2 n3 n4 n5 b -> IdentityT5 p1 p2 p3 p4 p5 c+lift5IdentityT5 f a b = IdentityT5 (f (runIdentityT5 a) (runIdentityT5 b))++mapIdentityT5 :: (m1 (m2 (m3 (m4 (m5 a)))) -> n1 (n2 (n3 (n4 (n5 b))))) -> IdentityT5 m1 m2 m3 m4 m5 a -> IdentityT5 n1 n2 n3 n4 n5 b+mapIdentityT5 f = IdentityT5 . f . runIdentityT5++liftCallCC5 :: CallCC5 m1 m2 m3 m4 m5 a b -> CallCC (IdentityT5 m1 m2 m3 m4 m5) a b+liftCallCC5 callCC f = IdentityT5 $ callCC $ \c -> runIdentityT5 $ (c >-> IdentityT5) >- f++liftCatch5 :: Catch5 e m1 m2 m3 m4 m5 a -> Catch e (IdentityT5 m1 m2 m3 m4 m5) a+liftCatch5 catch m h = IdentityT5 $ (runIdentityT5 m) `catch` (h >-> runIdentityT5)++instance MonadTrans5Down IdentityT5 where+    type Trans5Down IdentityT5 = IdentityT4++instance MonadTransFold5 IdentityT5 where+    transfold5 (IdentityT5 x) = IdentityT $ trans4 x+    untransfold5 (IdentityT x) = IdentityT5 $ untrans4 x++instance MonadTransCover5 IdentityT5 where+    (|----*|) = IdentityT5 . (----*) . runIdentityT4+    (|---*-|) = IdentityT5 . (---*) . runIdentityT4+    (|--*--|) = IdentityT5 . (--*) . runIdentityT4+    (|-*---|) = IdentityT5 . (-*) . runIdentityT4+    (|*----|) = IdentityT5 . (*:) . runIdentityT4++

@@ -9,31 +9,16 @@ Stability   : experimental Portability : --- -This module extended RWS Monad in mtl(monad-transformer-library).+This module extended RWS monad in mtl(monad-transformer-library). -}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-} module DeepControl.Monad.Trans.RWS (     module Control.Monad.RWS,     MonadReader(..), MonadWriter(..), MonadState(..), -    -- * Level-2-    RWST2(..), rwsT2, evalRWST2, execRWST2, mapRWST2, withRWST2, -    -- ** lift function-    liftCatch2,--    -- * Level-3-    RWST3(..), rwsT3, evalRWST3, execRWST3, mapRWST3, withRWST3, -    -- ** lift function-    liftCatch3,-     ) where   import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.Monad.Signatures import DeepControl.Monad.Trans  import Control.Monad.Reader (MonadReader(..))@@ -51,162 +36,4 @@ instance (Monoid w) => MonadTransCover (RWST r w s) where     (|*|) = RWST . ((*:)|$>>) . runRWS -------------------------------------------------------------------------- Level-2--newtype RWST2 r w s m1 m2 a = RWST2 { runRWST2 :: r -> s -> m1 (m2 (a, s, w)) }-    deriving (Functor)-{--instance (Functor m1, Functor m2) => Functor (RWST2 r w s m1 m2) where-    fmap f m = RWST2 $ \r s ->-        (\(a, s', w) -> (f a, s', w)) |$>> runRWST2 m r s--}-instance (Monoid w, Monad m1, Monad2 m2) => Applicative (RWST2 r w s m1 m2) where-    pure a = RWST2 $ \_ s -> (**:) (a, s, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2) => Monad (RWST2 r w s m1 m2) where-    return = pure-    m >>= k = RWST2 $ \r s -> -        runRWST2 m r s >>== \(a, s', w) ->-        runRWST2 (k a) r s' >>== \(b, s'',w') ->-        (**:) (b, s'', w <> w')-instance (Monoid w, Monad m1, Monad2 m2) => MonadReader r (RWST2 r w s m1 m2) where-    ask       = RWST2 $ \r s -> (**:) (r, s, mempty)-    local f m = RWST2 $ \r s -> runRWST2 m (f r) s-instance (Monoid w, Monad m1, Monad2 m2) => MonadWriter w (RWST2 r w s m1 m2) where-    writer (a, w) = RWST2 $ \_ s -> (**:) (a, s, w)-    tell w        = RWST2 $ \_ s -> (**:) ((),s,w)-    listen m      = RWST2 $ \r s -> -        runRWST2 m r s >>== \(a, s', w) ->-        (**:) ((a, w), s', w)-    pass m        = RWST2 $ \r s ->-        runRWST2 m r s >>== \((a, f), s', w) ->-        (**:) (a, s', f w)-instance (Monoid w, Monad m1, Monad2 m2) => MonadState s (RWST2 r w s m1 m2) where-    get   = RWST2 $ \_ s -> (**:) (s, s, mempty)-    put s = RWST2 $ \_ _ -> (**:) ((), s, mempty)--instance (Monoid w) => MonadTrans2 (RWST2 r w s) where-    lift2 m = RWST2 $ \r s -> -        m >>== \a ->-        (**:) (a, s, mempty)-instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (RWST2 r w s m1 m2) where-    liftIO = lift2 . (-*) . liftIO--instance (Monoid w) => MonadTrans2Down (RWST2 r w s) where-    type Trans2Down (RWST2 r w s) = RWST r w s--instance (Monoid w) => MonadTransFold2 (RWST2 r w s) where-    transfold2 (RWST2 x) = RWST $ trans |$>> x-    untransfold2 (RWST x) = RWST2 $ untrans |$>> x--instance (Monoid w) => MonadTransCover2 (RWST2 r w s) where-    (|-*|) = RWST2 . ((-*)|$>>) . runRWST-    (|*-|) = RWST2 . ((*-)|$>>) . runRWST--rwsT2 :: (Monad m1, Monad2 m2) => (r -> s -> (a, s, w)) -> RWST2 r w s m1 m2 a-rwsT2 = RWST2 . ((**:)|$>>)-evalRWST2 :: (Monad m1, Monad2 m2) => RWST2 r w s m1 m2 a -> r -> s -> m1 (m2 (a, w))-evalRWST2 m r s =-    runRWST2 m r s >>== \(a, _, w) ->-    (**:) (a, w)-execRWST2 :: (Monad m1, Monad2 m2) => RWST2 r w s m1 m2 a -> r -> s -> m1 (m2 (s, w))-execRWST2 m r s =-    runRWST2 m r s >>== \(_, s', w) ->-    (**:) (s', w)--mapRWST2 :: (m1 (m2 (a, s, w)) -> n1 (n2 (b, s, w'))) -> RWST2 r w s m1 m2 a -> RWST2 r w' s n1 n2 b-mapRWST2 f m = RWST2 $ \r s -> f (runRWST2 m r s)-withRWST2 :: (r' -> s -> (r, s)) -> RWST2 r w s m1 m2 a -> RWST2 r' w s m1 m2 a-withRWST2 f m = RWST2 $ \r s -> uncurry (runRWST2 m) (f r s)--liftCatch2 :: Catch2 e m1 m2 (a,s,w) -> Catch e (RWST2 r w s m1 m2) a-liftCatch2 catch m h = RWST2 $ \r s -> runRWST2 m r s `catch` \e -> runRWST2 (h e) r s--instance (Monoid w, MonadPlus m1, MonadPlus m2, Monad m1, Monad2 m2) => MonadPlus (RWST2 r w s m1 m2) where-    mzero       = RWST2 $ \_ _ -> mzero-    m `mplus` n = RWST2 $ \r s -> runRWST2 m r s <$|mplus|*> runRWST2 n r s-instance (Monoid w, MonadPlus m1, MonadPlus m2, Monad m1, Monad2 m2) => Alternative (RWST2 r w s m1 m2) where-    empty = mzero-    (<|>) = mplus--------------------------------------------------------------------------- Level-3--newtype RWST3 r w s m1 m2 m3 a = RWST3 { runRWST3 :: r -> s -> m1 (m2 (m3 (a, s, w))) }-    deriving (Functor)-{--instance (Functor m1, Functor m2, Functor m3) => Functor (RWST3 r w s m1 m2 m3) where-    fmap f m = RWST3 $ \r s ->-        (\(a, s', w) -> (f a, s', w)) |$>>> runRWST3 m r s--}-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Applicative (RWST3 r w s m1 m2 m3) where-    pure a = RWST3 $ \_ s -> (***:) (a, s, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Monad (RWST3 r w s m1 m2 m3) where-    return = pure-    m >>= k = RWST3 $ \r s -> -        runRWST3 m r s >>>== \(a, s', w) ->-        runRWST3 (k a) r s' >>>== \(b, s'',w') ->-        (***:) (b, s'', w <> w')-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadReader r (RWST3 r w s m1 m2 m3) where-    ask       = RWST3 $ \r s -> (***:) (r, s, mempty)-    local f m = RWST3 $ \r s -> runRWST3 m (f r) s-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadWriter w (RWST3 r w s m1 m2 m3) where-    writer (a, w) = RWST3 $ \_ s -> (***:) (a, s, w)-    tell w        = RWST3 $ \_ s -> (***:) ((), s, w)-    listen m      = RWST3 $ \r s -> -        runRWST3 m r s >>>== \(a, s', w) ->-        (***:) ((a, w), s', w)-    pass m        = RWST3 $ \r s ->-        runRWST3 m r s >>>== \((a, f), s', w) ->-        (***:) (a, s', f w)-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadState s (RWST3 r w s m1 m2 m3) where-    get   = RWST3 $ \_ s -> (***:) (s, s, mempty)-    put s = RWST3 $ \_ _ -> (***:) ((), s, mempty)--instance (Monoid w) => MonadTrans3 (RWST3 r w s) where-    lift3 m = RWST3 $ \r s -> -        m >>>== \a ->-        (***:) (a, s, mempty)-instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (RWST3 r w s m1 m2 m3) where-    liftIO = lift3 . (-**) . liftIO--instance (Monoid w) => MonadTrans3Down (RWST3 r w s) where-    type Trans3Down (RWST3 r w s) = RWST2 r w s--instance (Monoid w) => MonadTransFold3 (RWST3 r w s) where-    transfold3 (RWST3 x) = RWST $ trans2 |$>> x-    untransfold3 (RWST x) = RWST3 $ untrans2 |$>> x--instance (Monoid w) => MonadTransCover3 (RWST3 r w s) where-    (|--*|) = RWST3 . ((--*)|$>>) . runRWST2-    (|-*-|) = RWST3 . ((-*-)|$>>) . runRWST2-    (|*--|) = RWST3 . ((*--)|$>>) . runRWST2--rwsT3 :: (Monad m1, Monad2 m2, Monad3 m3) => (r -> s -> (a, s, w)) -> RWST3 r w s m1 m2 m3 a-rwsT3 = RWST3 . ((***:)|$>>)-evalRWST3 :: (Monad m1, Monad2 m2, Monad3 m3) => RWST3 r w s m1 m2 m3 a -> r -> s -> m1 (m2 (m3 (a, w)))-evalRWST3 m r s =-    runRWST3 m r s >>>== \(a, _, w) ->-    (***:) (a, w)-execRWST3 :: (Monad m1, Monad2 m2, Monad3 m3) => RWST3 r w s m1 m2 m3 a -> r -> s -> m1 (m2 (m3 (s, w)))-execRWST3 m r s =-    runRWST3 m r s >>>== \(_, s', w) ->-    (***:) (s', w)--mapRWST3 :: (m1 (m2 (m3 (a, s, w))) -> n1 (n2 (n3 (b, s, w')))) -> RWST3 r w s m1 m2 m3 a -> RWST3 r w' s n1 n2 n3 b-mapRWST3 f m = RWST3 $ \r s -> f (runRWST3 m r s)-withRWST3 :: (r' -> s -> (r, s)) -> RWST3 r w s m1 m2 m3 a -> RWST3 r' w s m1 m2 m3 a-withRWST3 f m = RWST3 $ \r s -> uncurry (runRWST3 m) (f r s)--liftCatch3 :: Catch3 e m1 m2 m3 (a,s,w) -> Catch e (RWST3 r w s m1 m2 m3) a-liftCatch3 catch m h = RWST3 $ \r s -> runRWST3 m r s `catch` \e -> runRWST3 (h e) r s--instance (Monoid w, MonadPlus m1, MonadPlus m2, MonadPlus m3, Monad m1, Monad2 m2, Monad3 m3) => MonadPlus (RWST3 r w s m1 m2 m3) where-    mzero       = RWST3 $ \_ _ -> mzero-    m `mplus` n = RWST3 $ \r s -> runRWST3 m r s <<$|mplus|*>> runRWST3 n r s-instance (Monoid w, MonadPlus m1, MonadPlus m2, MonadPlus m3, Monad m1, Monad2 m2, Monad3 m3) => Alternative (RWST3 r w s m1 m2 m3) where-    empty = mzero-    (<|>) = mplus 

@@ -11,31 +11,15 @@ Stability   : experimental Portability : --- -This module extended Reader Monad of mtl(monad-transformer-library).+This module extended Reader monad of mtl(monad-transformer-library). -}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveFunctor #-} module DeepControl.Monad.Trans.Reader (     module Control.Monad.Reader,--    -- * Level-2-    ReaderT2(..), mapReaderT2, -    -- ** lift function-    liftCatch2,--    -- * Level-3-    ReaderT3(..), mapReaderT3, -    -- ** lift function-    liftCatch3,-    +        ) where   import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.Monad.Signatures import DeepControl.Monad.Trans  import Control.Monad.Reader @@ -49,110 +33,4 @@ instance MonadTransCover (ReaderT s) where     (|*|) = ReaderT . ((*:)|$>) . runReader -------------------------------------------------------------------------- Level-2--newtype ReaderT2 r m1 m2 a = ReaderT2 { runReaderT2 :: r -> m1 (m2 a) }-    deriving (Functor)-{--instance (Functor m1, Functor m2) => Functor (ReaderT2 r m1 m2) where-    fmap f m = ReaderT2 $ \r ->-        f |$>> runReaderT2 m r--}-instance (Monad m1, Monad2 m2) => Applicative (ReaderT2 s m1 m2) where-    pure a = ReaderT2 $ \_ -> (**:) a-    (<*>)  = ap-instance (Monad m1, Monad2 m2) => Monad (ReaderT2 r m1 m2) where-    return = pure-    (ReaderT2 v) >>= f = ReaderT2 $ \r ->-        v r >>== \a -> -        runReaderT2 (f a) r-instance (Monad m1, Monad2 m2) => MonadReader r (ReaderT2 r m1 m2) where-    ask       = ReaderT2 $ (**:)-    local f m = ReaderT2 $ runReaderT2 m . f--instance MonadTrans2 (ReaderT2 r) where-    lift2 m = ReaderT2 $ \r -> -        m >>== \a ->-        (**:) a-instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (ReaderT2 r m1 m2) where-    liftIO = lift2 . (-*) . liftIO--instance MonadTrans2Down (ReaderT2 r) where-    type Trans2Down (ReaderT2 r) = ReaderT r--instance MonadTransFold2 (ReaderT2 r) where-    transfold2 (ReaderT2 x) = ReaderT $ x <$| trans-    untransfold2 (ReaderT x) = ReaderT2 $ x <$| untrans--instance MonadTransCover2 (ReaderT2 r) where-    (|-*|) = ReaderT2 . ((-*)|$>) . runReaderT-    (|*-|) = ReaderT2 . ((*-)|$>) . runReaderT--mapReaderT2 :: (m1 (m2 a) -> n1 (n2 b)) -> ReaderT2 r m1 m2 a -> ReaderT2 r n1 n2 b-mapReaderT2 f m = ReaderT2 $ f . runReaderT2 m--liftCatch2 :: Catch2 e m1 m2 a -> Catch e (ReaderT2 r m1 m2) a-liftCatch2 catch m h = ReaderT2 $ \r -> (runReaderT2 m r) `catch` (\e -> runReaderT2 (h e) r)--instance (Alternative m1, Alternative m2, Monad m1, Monad2 m2) => Alternative (ReaderT2 r m1 m2) where-    empty   = ReaderT2 (const empty)-    m <|> n = ReaderT2 $ \r -> runReaderT2 m r <$|(<|>)|*> runReaderT2 n r-instance (MonadPlus m1, MonadPlus m2, Monad m1, Monad2 m2) => MonadPlus (ReaderT2 r m1 m2) where-    mzero       = lift2 mzero-    m `mplus` n = ReaderT2 $ \r -> runReaderT2 m r <$|mplus|*> runReaderT2 n r--------------------------------------------------------------------------- Level-3--newtype ReaderT3 r m1 m2 m3 a = ReaderT3 { runReaderT3 :: r -> m1 (m2 (m3 a)) }-    deriving (Functor)-{--instance (Functor m1, Functor m2, Functor m3) => Functor (ReaderT3 r m1 m2 m3) where-    fmap f m = ReaderT3 $ \r ->-        f |$>>> runReaderT3 m r--}-instance (Monad m1, Monad2 m2, Monad3 m3) => Applicative (ReaderT3 s m1 m2 m3) where-    pure a = ReaderT3 $ \_ -> (***:) a-    (<*>)  = ap-instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (ReaderT3 r m1 m2 m3) where-    return = pure-    (ReaderT3 v) >>= f = ReaderT3 $ \r ->-        v r >>>== \a -> -        runReaderT3 (f a) r-instance (Monad m1, Monad2 m2, Monad3 m3) => MonadReader r (ReaderT3 r m1 m2 m3) where-    ask       = ReaderT3 $ (***:)-    local f m = ReaderT3 $ runReaderT3 m . f--instance MonadTrans3 (ReaderT3 r) where-    lift3 m = ReaderT3 $ \r -> -        m >>>== \a ->-        (***:) a-instance (MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (ReaderT3 r m1 m2 m3) where-    liftIO = lift3 . (-**) . liftIO--instance MonadTrans3Down (ReaderT3 r) where-    type Trans3Down (ReaderT3 r) = ReaderT2 r--instance MonadTransFold3 (ReaderT3 r) where-    transfold3 (ReaderT3 x) = ReaderT $ x <$| trans2-    untransfold3 (ReaderT x) = ReaderT3 $ x <$| untrans2--instance MonadTransCover3 (ReaderT3 r) where-    (|--*|) = ReaderT3 . ((--*)|$>) . runReaderT2-    (|-*-|) = ReaderT3 . ((-*-)|$>) . runReaderT2-    (|*--|) = ReaderT3 . ((*--)|$>) . runReaderT2--mapReaderT3 :: (m1 (m2 (m3 a)) -> n1 (n2 (n3 b))) -> ReaderT3 r m1 m2 m3 a -> ReaderT3 r n1 n2 n3 b-mapReaderT3 f m = ReaderT3 $ f . runReaderT3 m--liftCatch3 :: Catch3 e m1 m2 m3 a -> Catch e (ReaderT3 r m1 m2 m3) a-liftCatch3 catch m h = ReaderT3 $ \r -> (runReaderT3 m r) `catch` (\e -> runReaderT3 (h e) r)--instance (MonadPlus m1, MonadPlus m2, MonadPlus m3, Monad m1, Monad2 m2, Monad3 m3) => MonadPlus (ReaderT3 r m1 m2 m3) where-    mzero       = lift3 mzero-    m `mplus` n = ReaderT3 $ \r -> runReaderT3 m r <<$|mplus|*>> runReaderT3 n r-instance (Alternative m1, Alternative m2, Alternative m3, Monad m1, Monad2 m2, Monad3 m3) => Alternative (ReaderT3 r m1 m2 m3) where-    empty   = ReaderT3 (const empty)-    m <|> n = ReaderT3 $ \r -> runReaderT3 m r <<$|(<|>)|*>> runReaderT3 n r 

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-} {-| Module      : DeepControl.Monad.Trans.State Description : Extension for mtl's Contrl.Monad.State.@@ -10,34 +9,27 @@ Stability   : experimental Portability : --- -This module extended State Monad of mtl(monad-transformer-library).+This module extended State monad of mtl(monad-transformer-library). -}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}+--{-# LANGUAGE TypeSynonymInstances #-}+--{-# LANGUAGE GeneralizedNewtypeDeriving #-} module DeepControl.Monad.Trans.State (     module Control.Monad.State,      -- * Level-2-    StateT2(..), evalStateT2, execStateT2, mapStateT2, withStateT2, -    -- ** lift functions-    liftCatch2, liftListen2, liftPass2,--    -- * Level-3-    StateT3(..), evalStateT3, execStateT3, mapStateT3, withStateT3,-    -- ** lift functions-    liftCatch3, liftListen3, liftPass3,+    -- StateT2(..), runStateT2,      ) where   import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.Monad.Signatures import DeepControl.Monad.Trans  import Control.Monad.State  +-- import DeepControl.Monad+-- import DeepControl.Monad.Trans.Identity+ ---------------------------------------------------------------------- -- Level-1 @@ -50,148 +42,49 @@ ---------------------------------------------------------------------- -- Level-2 -newtype StateT2 s m1 m2 a = StateT2 { runStateT2 :: (s -> m1 (m2 (a,s))) }-    deriving (Functor) {--instance (Functor m1, Functor m2) => Functor (StateT2 s m1 m2) where-    fmap f v = StateT2 $ \s ->-        (\(a, s') -> (f a, s')) |$>> runStateT2 v s--}-instance (Monad m1, Monad2 m2) => Applicative (StateT2 s m1 m2) where-    pure a = StateT2 $ \s -> (**:) (a,s)-    (<*>)  = ap-instance (Monad m1, Monad2 m2) => Monad (StateT2 s m1 m2) where-    return = pure-    (StateT2 v) >>= f = -        StateT2 $ \s -> -            v s >>== \(a, s') ->-            runStateT2 (f a) s'-instance (Monad m1, Monad2 m2) => MonadState s (StateT2 s m1 m2) where-    get   = StateT2 $ \s -> (**:) (s, s)-    put s = StateT2 $ \_ -> (**:) ((), s)+newtype StateT2 s m1 m2 a = StateT2 (StateT s (IdentityT2 m1 m2) a)+  deriving (Functor, Applicative, Monad, MonadIO) +stateT2 :: (s -> m1 (m2 (a, s))) -> StateT2 s m1 m2 a+stateT2 = StateT2 . StateT . (IdentityT2|$>)+runStateT2 :: StateT2 s m1 m2 a -> s -> m1 (m2 (a, s))+runStateT2 (StateT2 x) = (runIdentityT2|$>) . runStateT $ x + instance MonadTrans2 (StateT2 s) where-    lift2 m = StateT2 $ \s -> -        m >>== \a ->-        (**:) (a, s)-instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (StateT2 s m1 m2) where-    liftIO = lift2 . (-*) . liftIO+    lift2 x = stateT2 $ \s -> x <<$|(,)|** s  instance MonadTrans2Down (StateT2 s) where     type Trans2Down (StateT2 s) = StateT s  instance MonadTransFold2 (StateT2 s) where-    transfold2 (StateT2 x) = StateT $ x <$| trans-    untransfold2 (StateT x) = StateT2 $ x <$| untrans--instance MonadTransCover2 (StateT2 w) where-    (|-*|) = StateT2 . ((-*)|$>) . runStateT-    (|*-|) = StateT2 . ((*-)|$>) . runStateT--evalStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 a)-evalStateT2 m s = -    runStateT2 m s >>== \(a, _) ->-    (**:) a-execStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 s)-execStateT2 m s = -    runStateT2 m s >>== \(_, s') ->-    (**:) s'--mapStateT2 :: (m1 (m2 (a, s)) -> n1 (n2 (b, s))) -> StateT2 s m1 m2 a -> StateT2 s n1 n2 b-mapStateT2 f m = StateT2 $ f . runStateT2 m-withStateT2 :: (s -> s) -> StateT2 s m1 m2 a -> StateT2 s m1 m2 a-withStateT2 f m = StateT2 $ runStateT2 m . f--liftCatch2 :: Catch2 e m1 m2 (a,s) -> Catch e (StateT2 s m1 m2) a-liftCatch2 catch m h = StateT2 $ \s -> runStateT2 m s `catch` \e -> runStateT2 (h e) s-liftListen2 :: (Monad m1, Monad2 m2) => Listen2 w m1 m2 (a,s) -> Listen w (StateT2 s m1 m2) a-liftListen2 listen m = StateT2 $ \s -> -    listen (runStateT2 m s) >>== \((a, s'), w) ->-    (**:) ((a, w), s')-liftPass2 :: (Monad m1, Monad2 m2) => Pass2 w m1 m2 (a,s) -> Pass w (StateT2 s m1 m2) a-liftPass2 pass m = StateT2 $ \s -> pass $-    runStateT2 m s >>== \((a, f), s') ->-    (**:) ((a, s'), f)--instance (MonadPlus m1, MonadPlus m2, Monad m1, Monad2 m2) => MonadPlus (StateT2 s m1 m2) where-    mzero       = StateT2 $ \ _ -> mzero-    m `mplus` n = StateT2 $ \ s -> runStateT2 m s <$|mplus|*> runStateT2 n s-instance (MonadPlus m1, MonadPlus m2, Monad m1, Monad2 m2) => Alternative (StateT2 s m1 m2) where-    empty = mzero-    (<|>) = mplus--------------------------------------------------------------------------- Level-3+    transfold2 x = StateT $ trans |$> runStateT2 x+    untransfold2 x = stateT2 $ untrans |$> runStateT x -newtype StateT3 s m1 m2 m3 a = StateT3 { runStateT3 :: (s -> m1 (m2 (m3 (a,s)))) }-    deriving (Functor)-{--instance (Functor m1, Functor m2, Functor m3) => Functor (StateT3 s m1 m2 m3) where-    fmap f v = StateT3 $ \s ->-        (\(a, s') -> (f a, s')) |$>>> runStateT3 v s+instance MonadTransCover2 (StateT2 s) where+    (|-*|) = stateT2 . ((-*)|$>) . runStateT+    (|*-|) = stateT2 . ((*-)|$>) . runStateT -}-instance (Monad m1, Monad2 m2, Monad3 m3) => Applicative (StateT3 s m1 m2 m3) where-    pure a = StateT3 $ \s -> (***:) (a,s)-    (<*>)  = ap-instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (StateT3 s m1 m2 m3) where-    return = pure-    (StateT3 v) >>= f = -        StateT3 $ \s -> -            v s >>>== \(a, s') ->-            runStateT3 (f a) s'-instance (Monad m1, Monad2 m2, Monad3 m3) => MonadState s (StateT3 s m1 m2 m3) where-    get   = StateT3 $ \s -> (***:) (s, s)-    put s = StateT3 $ \_ -> (***:) ((), s) -instance MonadTrans3 (StateT3 s) where-    lift3 m = StateT3 $ \s -> -        m >>>== \a ->-        (***:) (a, s)-instance (MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (StateT3 s m1 m2 m3) where-    liftIO = lift3 . (-**) . liftIO--instance MonadTrans3Down (StateT3 s) where-    type Trans3Down (StateT3 s) = StateT2 s--instance MonadTransFold3 (StateT3 s) where-    transfold3 (StateT3 x) = StateT $ x <$| trans2-    untransfold3 (StateT x) = StateT3 $ x <$| untrans2--instance MonadTransCover3 (StateT3 s) where-    (|--*|) = StateT3 . ((--*)|$>) . runStateT2-    (|-*-|) = StateT3 . ((-*-)|$>) . runStateT2-    (|*--|) = StateT3 . ((*--)|$>) . runStateT2+{-+type StateT2 s m1 m2 a = StateT s (IdentityT2 m1 m2) a -evalStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 a))-evalStateT3 m s = -    runStateT3 m s >>>== \(a, _) ->-    (***:) a-execStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 s))-execStateT3 m s = -    runStateT3 m s >>>== \(_, s') ->-    (***:) s'+stateT2 :: (s -> m1 (m2 (a, s))) -> StateT2 s m1 m2 a+stateT2 = StateT . (IdentityT2|$>)+runStateT2 :: StateT2 s m1 m2 a -> s -> m1 (m2 (a, s))+runStateT2 = (runIdentityT2|$>) . runStateT -mapStateT3 :: (m1 (m2 (m3 (a, s))) -> n1 (n2 (n3 (b, s)))) -> StateT3 s m1 m2 m3 a -> StateT3 s n1 n2 n3 b-mapStateT3 f m = StateT3 $ f . runStateT3 m-withStateT3 :: (s -> s) -> StateT3 s m1 m2 m3 a -> StateT3 s m1 m2 m3 a-withStateT3 f m = StateT3 $ runStateT3 m . f+instance MonadTrans2Down (StateT2 s) where+    type Trans2Down (StateT2 s) = StateT s -liftCatch3 :: Catch3 e m1 m2 m3 (a,s) -> Catch e (StateT3 s m1 m2 m3) a-liftCatch3 catch m h = StateT3 $ \s -> runStateT3 m s `catch` \e -> runStateT3 (h e) s-liftListen3 :: (Monad m1, Monad2 m2, Monad3 m3) => Listen3 w m1 m2 m3 (a,s) -> Listen w (StateT3 s m1 m2 m3) a-liftListen3 listen m = StateT3 $ \s -> -    listen (runStateT3 m s) >>>== \((a, s'), w) ->-    (***:) ((a, w), s')-liftPass3 :: (Monad m1, Monad2 m2, Monad3 m3) => Pass3 w m1 m2 m3 (a,s) -> Pass w (StateT3 s m1 m2 m3) a-liftPass3 pass m = StateT3 $ \s -> pass $-    runStateT3 m s >>>== \((a, f), s') ->-    (***:) ((a, s'), f)+-- TODO: error+instance MonadTransFold2 (StateT2 s) where+    transfold2 x = StateT $ trans |$> runStateT2 x+    untransfold2 x = stateT2 $ untrans |$> runStateT x -instance (MonadPlus m1, MonadPlus m2, MonadPlus m3, Monad m1, Monad2 m2, Monad3 m3) => MonadPlus (StateT3 s m1 m2 m3) where-    mzero       = StateT3 $ \ _ -> mzero-    m `mplus` n = StateT3 $ \ s -> runStateT3 m s <<$|mplus|*>> runStateT3 n s-instance (MonadPlus m1, MonadPlus m2, MonadPlus m3, Monad m1, Monad2 m2, Monad3 m3) => Alternative (StateT3 s m1 m2 m3) where-    empty = mzero-    (<|>) = mplus+instance MonadTransCover2 (StateT2 s) where+    (|-*|) = stateT2 . ((-*)|$>) . runStateT+    (|*-|) = stateT2 . ((*-)|$>) . runStateT+-}  

@@ -1,5 +1,5 @@ {-|-Module      : DeepControl.Monad.Trans.State+Module      : DeepControl.Monad.Trans.Writer Description : Extension for mtl's Contrl.Monad.Writer. Copyright   : (c) Andy Gill 2001,               (c) Oregon Graduate Institute of Science and Technology, 2001,@@ -9,7 +9,7 @@ Stability   : experimental Portability : --- -This module extended Writer Monad of mtl(monad-transformer-library).+This module extended Writer monad of mtl(monad-transformer-library). -} {-# LANGUAGE FlexibleInstances #-} module DeepControl.Monad.Trans.Writer (@@ -24,12 +24,6 @@     -- * Level-5     --listen5, pass5, -{--    -- * Level-2-    WriterT2(..), execWriterT2, mapWriterT2, liftCatch2,-    -- * Level-3-    WriterT3(..), execWriterT3, mapWriterT3, liftCatch3,--}     ) where   import DeepControl.Applicative@@ -96,132 +90,3 @@         f a <<<<$| (\x -> runWriterT x >- \(Identity (b, w')) ->                           WriterT $ Identity (b, w <> w')) ---{--------------------------------------------------------------------------- Level-1---instance (Monoid w) => MonadTrans_ (WriterT w) where-    untrans x = (WriterT . Identity) |$> runWriterT x-    trans x   = WriterT ((runIdentity . runWriterT) |$> x)-instance (Monoid w) => MonadTransDown (WriterT w) where-    type TransDown (WriterT w) = Writer w-instance (Monoid w) => MonadTransCover (WriterT w) where-    (|*|) = WriterT . (*:) . runWriter--------------------------------------------------------------------------- Level-2---newtype WriterT2 w m1 m2 a = WriterT2 { runWriterT2 :: m1 (m2 (a, w)) }-    deriving (Functor)-{--instance (Monad m1, Monad2 m2) => Functor (WriterT2 w m1 m2) where-    fmap f v = WriterT2 $ (\(a, w) -> (f a, w)) |$>> runWriterT2 v--}-instance (Monoid w, Monad m1, Monad2 m2) => Applicative (WriterT2 w m1 m2) where-    pure a = WriterT2 $ (**:) (a, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2) => Monad (WriterT2 w m1 m2) where  -    return = pure-    (WriterT2 v) >>= f = WriterT2 $-        v >>== \(a, w) ->-        runWriterT2 (f a) >>== \(a', w') ->-        (**:) (a', w <> w')-instance (Monoid w, Monad m1, Monad2 m2) => MonadWriter w (WriterT2 w m1 m2) where-    writer   = WriterT2 . (**:)-    tell w   = writer $ ((), w)-    listen m = WriterT2 $-        runWriterT2 m >>== \(a, w) ->-        (**:) ((a, w), w) -    pass m   = WriterT2 $-        runWriterT2 m >>== \((a, f), w) ->-        (**:) (a, f w)--instance (Monoid w) => MonadTrans2 (WriterT2 w) where-    lift2 m = WriterT2 $ -        m >>== \a ->-        (**:) (a, mempty)-instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (WriterT2 w m1 m2) where-    liftIO = lift2 . (-*) . liftIO--instance (Monoid w) => MonadTrans2Down (WriterT2 w) where-    type Trans2Down (WriterT2 w) = WriterT w-instance (Monoid w) => MonadTransFold2 (WriterT2 w) where-    transfold2 (WriterT2 x) = WriterT $ trans x-    untransfold2 (WriterT x) = WriterT2 $ untrans x-instance (Monoid w) => MonadTransCover2 (WriterT2 w) where-    (|-*|) = WriterT2 . (-*) . runWriterT-    (|*-|) = WriterT2 . (*-) . runWriterT--execWriterT2 :: (Monad m1, Monad2 m2) => WriterT2 w m1 m2 a -> m1 (m2 w)-execWriterT2 m =-    runWriterT2 m >>== \(_, w) ->-    (**:) w--mapWriterT2 :: (m1 (m2 (a, w)) -> n1 (n2 (b, w'))) -> WriterT2 w m1 m2 a -> WriterT2 w' n1 n2 b-mapWriterT2 f m = WriterT2 $ f (runWriterT2 m)--liftCatch2 :: Catch2 e m1 m2 (a,w) -> Catch e (WriterT2 w m1 m2) a-liftCatch2 catch m h = WriterT2 $ runWriterT2 m `catch` \e -> runWriterT2 (h e)--------------------------------------------------------------------------- Level-3--newtype WriterT3 w m1 m2 m3 a = WriterT3 { runWriterT3 :: m1 (m2 (m3 (a, w))) }-    deriving (Functor)-{--instance (Monad m1, Monad2 m2, Monad3 m3) => Functor (WriterT3 w m1 m2 m3) where-    fmap f v = WriterT3 $ (\(a, w) -> (f a, w)) |$>>> runWriterT3 v--}-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Applicative (WriterT3 w m1 m2 m3) where-    pure a = WriterT3 $ (***:) (a, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Monad (WriterT3 w m1 m2 m3) where  -    return = pure-    (WriterT3 v) >>= f = WriterT3 $-        v >>>== \(a, w) ->-        runWriterT3 (f a) >>>== \(a', w') ->-        (***:) (a', w <> w')-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadWriter w (WriterT3 w m1 m2 m3) where-    writer   = WriterT3 . (***:)-    tell w   = writer $ ((), w)-    listen m = WriterT3 $-        runWriterT3 m >>>== \(a, w) ->-        (***:) ((a, w), w) -    pass m   = WriterT3 $-        runWriterT3 m >>>== \((a, f), w) ->-        (***:) (a, f w)--instance (Monoid w) => MonadTrans3 (WriterT3 w) where-    lift3 m = WriterT3 $ -        m >>>== \a ->-        (***:) (a, mempty)-instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (WriterT3 w m1 m2 m3) where-    liftIO = lift3 . (-**) . liftIO--instance (Monoid w) => MonadTrans3Down (WriterT3 w) where-    type Trans3Down (WriterT3 w) = WriterT2 w--instance (Monoid w) => MonadTransFold3 (WriterT3 w) where-    transfold3 (WriterT3 x) = WriterT $ trans2 x -    untransfold3 (WriterT x) = WriterT3 $ untrans2 x --instance (Monoid w) => MonadTransCover3 (WriterT3 w) where-    (|--*|) = WriterT3 . (--*) . runWriterT2-    (|-*-|) = WriterT3 . (-*-) . runWriterT2-    (|*--|) = WriterT3 . (*--) . runWriterT2--execWriterT3 :: (Monad m1, Monad2 m2, Monad3 m3) => WriterT3 w m1 m2 m3 a -> m1 (m2 (m3 w))-execWriterT3 m =-    runWriterT3 m >>>== \(_, w) ->-    (***:) w--mapWriterT3 :: (m1 (m2 (m3 (a, w))) -> n1 (n2 (n3 (b, w')))) -> WriterT3 w m1 m2 m3 a -> WriterT3 w' n1 n2 n3 b-mapWriterT3 f m = WriterT3 $ f (runWriterT3 m)--liftCatch3 :: Catch3 e m1 m2 m3 (a,w) -> Catch e (WriterT3 w m1 m2 m3) a-liftCatch3 catch m h = WriterT3 $ runWriterT3 m `catch` \e -> runWriterT3 (h e)--}

@@ -323,13 +323,15 @@  #### Level-2 -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.+Here is a monad transformer example how to implement Ackermann function, improved to stop within a certain limit of time, with ReaderT-IdentityT2-IO-Maybe monad, a level-2 monad-transformation.  ```haskell import DeepControl.Applicative import DeepControl.Commutative (commute) import DeepControl.Monad ((>-))-import DeepControl.Monad.Trans (lift2, transfold2, untransfold2)+import DeepControl.Monad.Morph ((|>|))+import DeepControl.Monad.Trans (liftTT2, transfold2, untransfold2)+import DeepControl.Monad.Trans.Identity import DeepControl.Monad.Trans.Reader import Control.Monad.Trans.Maybe @@ -337,8 +339,8 @@  type TimeLimit = Int -ackermannTimeLimit :: TimeLimit -> Int -> Int-                      -> IO (Maybe Int)             -- IO-Maybe Monad+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@@ -347,67 +349,70 @@                     | m > 0 && n > 0  = ackermannIO m (n-1) >>= ackermannIO (m-1)   ackermann :: Int -> Int -> -               ReaderT2 TimeLimit IO Maybe Int      -- ReaderT2-IO-Maybe monad+             ReaderT TimeLimit (IdentityT2 IO Maybe) Int -- ReaderT-IdentityT2-IO-Maybe monad ackermann x y = do     timelimit <- ask-    lift2 $ ackermannTimeLimit timelimit x y        -- lift IO-Maybe function to ReaderT2-IO-Maybe function+    liftTT2 $ ackermannTimeLimit timelimit x y           -- lift IO-Maybe function to ReaderT-IdentityT2-IO-Maybe function  calc_ackermann :: TimeLimit -> Int -> Int -> IO (Maybe Int)-calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT2 r timelimit+calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT r timelimit+                                             >- runIdentityT2  -- λ> 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+              ReaderT TimeLimit (MaybeT IO) Int                -- ReaderT-MaybeT-IO monad+ackermann' x y = (runIdentityT . transfold2) |>| ackermann x y -- You can get usual ReaderT-MaybeT-IO function from ReaderT-IdentityT2-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+               ReaderT TimeLimit (IdentityT2 IO Maybe) Int      -- ReaderT-IdentityT2-IO-Maybe monad+ackermann'' x y = (untransfold2 . IdentityT) |>| ackermann' x y -- You can get ReaderT-IdentityT2-IO-Maybe function from usual ReaderT-MaybeT-IO function ``` -Here is a monad transformer example showing that the Monad Morphic programming is usable.+Here is a monad transformer example showing that the monad morph is usable.  ```haskell import DeepControl.Applicative ((|$>)) import DeepControl.Monad (Monad2)-import DeepControl.Monad.Trans (lift, (|*|), (|-*|), (|*-|))-import DeepControl.Monad.Trans.State+import DeepControl.Monad.Morph ((|>|))+import DeepControl.Monad.Trans (liftT, (|*|), (|-*|), (|*-|)) import DeepControl.Monad.Trans.Writer+import DeepControl.Monad.Trans.Identity+import DeepControl.Monad.Trans.State  tick :: State Int () tick = modify (+1) -tock                        ::                   StateT Int IO ()+tock                         ::                   StateT Int IO () tock = do-    (|*|) tick              :: (Monad      m) => StateT Int m  ()-    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()+    (|*|) tick               :: (Monad      m) => StateT Int m  ()+    liftT $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()  -- λ> runStateT tock 0 -- Tock! -- ((),1) -save :: StateT Int (Writer [Int]) ()+save    :: StateT Int (Writer [Int]) () save = do     n <- get-    lift $ tell [n]+    liftT $ tell [n] -program ::               StateT2 Int IO (Writer [Int]) ()+program ::               StateT Int (IdentityT2 IO (Writer [Int])) () program = replicateM_ 4 $ do-    (|-*|) tock-        :: (Monad2 m) => StateT2 Int IO m              ()-    (|*-|) save-        :: (Monad  m) => StateT2 Int m  (Writer [Int]) ()+    ((|-*|).liftT) |>| tock+        :: (Monad2 m) => StateT Int (IdentityT2 IO m             ) ()+    ((|*-|).liftT) |>| save+        :: (Monad  m) => StateT Int (IdentityT2 m  (Writer [Int])) () --- λ> execWriter |$> runStateT2 program 0+-- λ> execWriter |$> runIdentityT2 (runStateT program 0) -- Tock! -- Tock! -- Tock! -- Tock! -- [1,2,3,4] ```-#### Level-3+#### Level-3, Level-4 and Level-5  Work well likewise. 

@@ -1,5 +1,5 @@ name:                deepcontrol-version:             0.3.3.0+version:             0.4.1.0 synopsis:            Provide more deeper level style of programming than the usual Control.xxx modules express description:         This module enables more deeper level style of programming than the usual Control.xxx modules express, especially for Applicative and Monad. license:             BSD3@@ -7,7 +7,7 @@ author:              KONISHI Yohsuke maintainer:          ocean0yohsuke@gmail.com homepage:            https://github.com/ocean0yohsuke/deepcontrol-copyright:           KONISHI Yohsuke+copyright:           (c) 2015 KONISHI Yohsuke category:            Control build-type:          Simple -- extra-source-files:  @@ -28,11 +28,12 @@                      , DeepControl.Monad.Morph                      , DeepControl.Monad.Signatures                      , DeepControl.Monad.Trans+                     , DeepControl.Monad.Trans.Identity                      , DeepControl.Monad.Trans.Except-                     , DeepControl.Monad.Trans.RWS+                     , DeepControl.Monad.Trans.Writer                      , DeepControl.Monad.Trans.Reader                      , DeepControl.Monad.Trans.State-                     , DeepControl.Monad.Trans.Writer+                     , DeepControl.Monad.Trans.RWS   -- other-modules:          other-extensions:    MultiParamTypeClasses                      , FlexibleInstances@@ -110,12 +111,12 @@                       , HUnit >= 1.3.0                       , mtl, transformers                       , deepcontrol-Test-Suite unit_Monad-Level2-2+Test-Suite unit_MonadTrans-2   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              unit_Monad-Level2-2.hs+  Main-Is:              unit_MonadTrans-2.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , mtl, transformers

@@ -3,9 +3,9 @@  import DeepControl.Applicative ((|$>)) import DeepControl.Monad ((>-))+import DeepControl.Monad.Trans.RWS+import DeepControl.Monad.Trans.Except -import Control.Monad.Except-import Control.Monad.RWS import qualified Data.Map as M  ------------------------------------------------

@@ -1,87 +0,0 @@-import Test.HUnit--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--calc_ackermann' :: TimeLimit -> Int -> Int -> IO (Maybe Int)-calc_ackermann' timelimit x y = ackermann' x y >- \r -> runReaderT r timelimit-                                               >- runMaybeT---- λ> commute $ calc_ackermann' 1000 |$> [0..4] |* 4--- [Just 5,Just 6,Just 11,Just 125,Nothing]--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--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]--------------------------------------------------------------------- unit test-------------------------------------------------------------------main :: IO ()-main = do-    runTestTT tests_1-    runTestTT tests_2-    runTestTT tests_3-    return ()--tests_1 :: Test-tests_1 = test [ -      "calc" ~: do-        actual <- commute $ calc_ackermann 1000 |$> [0..4] |* 4-        actual @?= [Just 5,Just 6,Just 11,Just 125,Nothing]-    ]--tests_2 :: Test-tests_2 = test [ -      "calc" ~: do-        actual <- commute $ calc_ackermann' 1000 |$> [0..4] |* 4-        actual @?= [Just 5,Just 6,Just 11,Just 125,Nothing]-    ]--tests_3 :: Test-tests_3 = test [ -      "calc" ~: do-        actual <- commute $ calc_ackermann'' 1000 |$> [0..4] |* 4-        actual @?= [Just 5,Just 6,Just 11,Just 125,Nothing]-    ]-

@@ -1,14 +1,15 @@ import Test.HUnit hiding (State)  import DeepControl.Applicative -import DeepControl.Monad ((>-)) import DeepControl.Commutative (cmap)+import DeepControl.Monad ((>-))+import DeepControl.Monad.Morph import DeepControl.Monad.Trans-import DeepControl.Monad.Trans.State import DeepControl.Monad.Trans.Except+import DeepControl.Monad.Trans.Identity+import DeepControl.Monad.Trans.State  import Control.Monad.Trans.Maybe-import Control.Monad.Identity  ----------------------------------------------- -- State@@ -99,7 +100,7 @@ polandS "/" = do     x <- popS     y <- popS-    lift $ guard (x /= 0)+    liftT $ guard (x /= 0)     pushS (y / x) polandS x = pushS (read x :: Double) @@ -208,73 +209,62 @@                                                >- runMaybeT  -------------------------------------------------- StateT2-IO-Maybe--polandS2' :: String -> StateT2 [Double] IO Maybe Double-polandS2' s = untransfold2 $ polandSM s--poland_calcS2' :: [String] -> IO (Maybe (Double, [Double]))-poland_calcS2' xs = (cmap polandS2' xs >> popS2) >- \x -> runStateT2 x []---------------------------------------------------- StateT2-IO-Maybe+-- StateT-Identity2-IO-Maybe Monad -pushS2 :: a -> StateT2 [a] IO Maybe a-pushS2 x = do +pushSI2 :: a -> StateT [a] (IdentityT2 IO Maybe) a+pushSI2 x = do      xs <- get     put (x:xs)     return x-popS2 :: StateT2 [a] IO Maybe a-popS2 = do +popSI2 :: StateT [a] (IdentityT2 IO Maybe) a+popSI2 = do      xs <- get     put (tail xs)     return (head xs) -polandS2 :: String -> StateT2 [Double] IO Maybe Double-polandS2 "+" = do -    x <- popS2-    y <- popS2+polandSI2 :: String -> StateT [Double] (IdentityT2 IO Maybe) Double+polandSI2 "+" = do +    x <- popSI2+    y <- popSI2     liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))-    pushS2 (y + x)-polandS2 "-" = do -    x <- popS2-    y <- popS2+    pushSI2 (y + x)+polandSI2 "-" = do +    x <- popSI2+    y <- popSI2     liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))-    pushS2 (y - x)-polandS2 "*" = do-    x <- popS2-    y <- popS2+    pushSI2 (y - x)+polandSI2 "*" = do+    x <- popSI2+    y <- popSI2     liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))-    pushS2 (y * x)-polandS2 "/" = do-    x <- popS2-    y <- popS2+    pushSI2 (y * x)+polandSI2 "/" = do+    x <- popSI2+    y <- popSI2     liftIO $ putStr (show y ++" / "++ show x ++" = ")-    lift2 $ (*:) $ guard (x /= 0)+    liftT . liftT2 . (*:) $ guard (x /= 0)     liftIO $ putStr (show (y / x) ++"\n")-    pushS2 (y / x)-polandS2 x = pushS2 (read x :: Double)+    pushSI2 (y / x)+polandSI2 x = pushSI2 (read x :: Double) -poland_calcS2 :: [String] -> IO (Maybe (Double, [Double]))-poland_calcS2 xs = (cmap polandS2 xs >> popS2) >- \x -> runStateT2 x []+poland_calcSI2 :: [String] -> IO (Maybe (Double, [Double]))+poland_calcSI2 xs = (cmap polandSI2 xs >> popSI2) >- \x -> runStateT x []+                                                  >- runIdentityT2 --- > poland_calcS2 ["1","2","*"]--- 1.0 * 2.0 = 2.0--- Just (2.0, [])--- > poland_calcS2 ["1","2","+","3","*"]--- 1.0 + 2.0 = 3.0--- 3.0 * 3.0 = 9.0--- Just (9.0, [])--- > poland_calcS2 ["1","2","+","3","*","3","/"]--- 1.0 + 2.0 = 3.0--- 3.0 * 3.0 = 9.0--- 9.0 / 3.0 = 3.0--- Just (3.0, [])--- > poland_calcS2 ["1","2","+","3","*","0","/"]--- 1.0 + 2.0 = 3.0--- 3.0 * 3.0 = 9.0--- 9.0 / 0.0 = Nothing+-----------------------------------------------+-- StateT-IdentityT-MaybeT-IO +popSIM :: StateT [a] (IdentityT (MaybeT IO)) a+popSIM = transfold2 |>| popSI2++polandSIM :: String -> StateT [Double] (IdentityT (MaybeT IO)) Double+polandSIM s = transfold2 |>| polandSI2 s++poland_calcSIM :: [String] -> IO (Maybe (Double, [Double]))+poland_calcSIM xs = (cmap polandSIM xs >> popSIM) >- \x -> runStateT x []+                                                  >- runIdentityT+                                                  >- runMaybeT+ ----------------------------------------------- -- StateT-MaybeT-ExceptT-IO Monad @@ -320,52 +310,67 @@                                                   >- runExceptT  -------------------------------------------------- StateT3-IO-Except-Maybe Monad+-- StateT-IdentityT-MaybeT-ExceptT-IO -pushS3 :: a -> StateT3 [a] IO (Except ()) Maybe a-pushS3 x = do -    xs <- get-    put (x:xs)-    return x-popS3 :: StateT3 [a] IO (Except ()) Maybe a-popS3 = do -    xs <- get-    put (tail xs)-    return (head xs)+pushSIME :: a -> StateT [a] (IdentityT (MaybeT (ExceptT () IO))) a+pushSIME x = liftT |>| pushSME x+popSIME :: StateT [a] (IdentityT (MaybeT (ExceptT () IO))) a+popSIME = liftT |>| popSME+polandSIME :: String -> StateT [Double] (IdentityT (MaybeT (ExceptT () IO))) Double+polandSIME x = liftT |>| polandSME x -polandS3 :: String -> StateT3 [Double] IO (Except ()) Maybe Double-polandS3 s = untransfold3 $ polandSME s+poland_calcSIME :: [String] -> IO (Either () (Maybe (Double, [Double])))+poland_calcSIME xs = (cmap polandSIME xs >> popSIME) >- \x -> runStateT x []+                                                     >- runIdentityT+                                                     >- runMaybeT+                                                     >- runExceptT -poland_calcS3 :: [String] -> IO (Either () (Maybe (Double, [Double])))-poland_calcS3 xs = (cmap polandS3 xs >> popS3) >- \x -> runStateT3 x []-                                               >- (runExcept |$>) +-----------------------------------------------+-- StateT-IdentityT3-IO-Except-Maybe +pushSI3 :: a -> StateT [a] (IdentityT3 IO (Except ()) Maybe) a+pushSI3 x = untransfold3 |>| pushSIME x+popSI3 :: StateT [a] (IdentityT3 IO (Except ()) Maybe) a+popSI3 = untransfold3 |>| popSIME+polandSI3 :: String -> StateT [Double] (IdentityT3 IO (Except ()) Maybe) Double+polandSI3 x = untransfold3 |>| polandSIME x++poland_calcSI3 :: [String] -> IO (Either () (Maybe (Double, [Double])))+poland_calcSI3 xs = (cmap polandSI3 xs >> popSI3) >- \x -> runStateT x []+                                                  >- runIdentityT3+                                                  >- (runExcept|$>)+ ---------------------------------------------------------------- -- unit test ----------------------------------------------------------------  main :: IO () main = do-    runTestTT tests_Level0-    putStrLn "" >> print "---------------------"-    runTestTT tests_Level1-    putStrLn "" >> print "---------------------"-    runTestTT tests_Level1_2-    putStrLn "" >> print "---------------------"-    runTestTT tests_Level1_3-    putStrLn "" >> print "---------------------"-    runTestTT tests_Level2-    putStrLn "" >> print "---------------------"-    runTestTT tests_Level2_2-    putStrLn "" >> print "---------------------"-    runTestTT tests_Level3-    putStrLn "" >> print "---------------------"-    runTestTT tests_Level3_2+    runTestTT tests_+    putStrLn "" >> print "---------- S -----------"+    runTestTT tests_S++    putStrLn "" >> print "---------- MS -----------"+    runTestTT tests_MS++    putStrLn "" >> print "---------- SM -----------"+    runTestTT tests_SM++    putStrLn "" >> print "---------- SI2 -----------"+    runTestTT tests_SI2+    putStrLn "" >> print "---------- SIM -----------"+    runTestTT tests_SIM+    putStrLn "" >> print "---------- SIME -----------"+    runTestTT tests_SIME+    putStrLn "" >> print "---------- SI3 -----------"+    runTestTT tests_SI3++     putStrLn "" >> print "---------------------"     return () -tests_Level0 :: Test-tests_Level0 = test [ +tests_ :: Test+tests_ = test [        "poland" ~: do         let actual = poland_calc ["1","2","*"]         actual @?= (2.0, [])@@ -376,9 +381,8 @@         --actual <- poland_calc ["1","2","+","3","*","0","/"]         --actual @?= Infinity     ]--tests_Level1 :: Test-tests_Level1 = test [ +tests_S :: Test+tests_S = test [        "polandT" ~: do         let actual = poland_calcS ["1","2","*"]         actual @?= Just (2.0, [])@@ -389,9 +393,8 @@         let actual = poland_calcS ["1","2","+","3","*","0","/"]         actual @?= Nothing     ]--tests_Level1_2 :: Test-tests_Level1_2 = test [ +tests_MS :: Test+tests_MS = test [        "polandMS" ~: do         actual <- poland_calcMS ["1","2","*"]         actual @?= (Just 2.0, [])@@ -402,9 +405,8 @@         actual <- poland_calcMS ["1","2","+","3","*","0","/"]         actual @?= (Nothing, [])     ]--tests_Level1_3 :: Test-tests_Level1_3 = test [ +tests_SM :: Test+tests_SM = test [        "polandSM" ~: do         actual <- poland_calcSM ["1","2","*"]         actual @?= Just (2.0, [])@@ -415,44 +417,53 @@         actual <- poland_calcSM ["1","2","+","3","*","0","/"]         actual @?= Nothing     ]--tests_Level2 :: Test-tests_Level2 = test [ -      "polandS2" ~: do-        actual <- poland_calcS2 ["1","2","*"]+tests_SI2 :: Test+tests_SI2 = test [ +      "polandSI2" ~: do+        actual <- poland_calcSI2 ["1","2","*"]         actual @?= Just (2.0, []) -        actual <- poland_calcS2 ["1","2","+","3","*","0","/"]+        actual <- poland_calcSI2 ["1","2","+","3","*","3","/"]+        actual @?= Just (3.0, [])++        actual <- poland_calcSI2 ["1","2","+","3","*","0","/"]         actual @?= Nothing     ]--tests_Level2_2 :: Test-tests_Level2_2 = test [ -      "polandS2'" ~: do-        actual <- poland_calcS2' ["1","2","*"]+tests_SIM :: Test+tests_SIM = test [ +      "polandSIM" ~: do+        actual <- poland_calcSIM ["1","2","*"]         actual @?= Just (2.0, []) -        actual <- poland_calcS2' ["1","2","+","3","*","0","/"]+        actual <- poland_calcSIM ["1","2","+","3","*","3","/"]+        actual @?= Just (3.0, [])++        actual <- poland_calcSIM ["1","2","+","3","*","0","/"]         actual @?= Nothing     ]--tests_Level3 :: Test-tests_Level3 = test [ -      "polandSME'" ~: do-        actual <- poland_calcSME ["1","2","*"]+tests_SIME :: Test+tests_SIME = test [ +      "polandSIME" ~: do+        actual <- poland_calcSIME ["1","2","*"]         actual @?= Right (Just (2.0, [])) -        actual <- poland_calcSME ["1","2","+","3","*","0","/"]+        actual <- poland_calcSIME ["1","2","+","3","*","3","/"]+        actual @?= Right (Just (3.0, []))++        actual <- poland_calcSIME ["1","2","+","3","*","0","/"]         actual @?= Right Nothing     ]--tests_Level3_2 :: Test-tests_Level3_2 = test [ -      "polandS3" ~: do-        actual <- poland_calcS3 ["1","2","*"]+tests_SI3 :: Test+tests_SI3 = test [ +      "polandSI3" ~: do+        actual <- poland_calcSI3 ["1","2","*"]         actual @?= Right (Just (2.0, [])) -        actual <- poland_calcS3 ["1","2","+","3","*","0","/"]+        actual <- poland_calcSI3 ["1","2","+","3","*","3","/"]+        actual @?= Right (Just (3.0, []))++        actual <- poland_calcSI3 ["1","2","+","3","*","0","/"]         actual @?= Right Nothing     ]+ 

@@ -4,8 +4,7 @@ import DeepControl.Monad import DeepControl.Monad.Trans.Writer import DeepControl.Monad.Trans.Reader--import Control.Monad.Identity+import DeepControl.Monad.Trans.Identity  import Safe 

@@ -0,0 +1,85 @@+import Test.HUnit++import DeepControl.Applicative+import DeepControl.Commutative (commute)+import DeepControl.Monad ((>-))+import DeepControl.Monad.Morph ((|>|))+import DeepControl.Monad.Trans (liftTT2, transfold2, untransfold2)+import DeepControl.Monad.Trans.Identity+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 -> +             ReaderT TimeLimit (IdentityT2 IO Maybe) Int -- ReaderT-IdentityT2-IO-Maybe monad+ackermann x y = do+    timelimit <- ask+    liftTT2 $ ackermannTimeLimit timelimit x y           -- lift IO-Maybe function to ReaderT-IdentityT2-IO-Maybe function++calc_ackermann :: TimeLimit -> Int -> Int -> IO (Maybe Int)+calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT r timelimit+                                             >- runIdentityT2++-- λ> 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 = (runIdentityT . transfold2) |>| ackermann x y -- You can get usual ReaderT-MaybeT-IO function from ReaderT-IdentityT2-IO-Maybe function++calc_ackermann' :: TimeLimit -> Int -> Int -> IO (Maybe Int)+calc_ackermann' timelimit x y = ackermann' x y >- \r -> runReaderT r timelimit+                                               >- runMaybeT++ackermann'' :: Int -> Int -> +               ReaderT TimeLimit (IdentityT2 IO Maybe) Int      -- ReaderT-IdentityT2-IO-Maybe monad+ackermann'' x y = (untransfold2 . IdentityT) |>| ackermann' x y -- You can get ReaderT-IdentityT2-IO-Maybe function from usual ReaderT-MaybeT-IO function++calc_ackermann'' :: TimeLimit -> Int -> Int -> IO (Maybe Int)+calc_ackermann'' timelimit x y = ackermann'' x y >- \r -> runReaderT r timelimit+                                                 >- runIdentityT2++----------------------------------------------------------------+-- unit test+----------------------------------------------------------------++main :: IO ()+main = do+    runTestTT tests_1+    runTestTT tests_2+    runTestTT tests_3+    return ()++tests_1 :: Test+tests_1 = test [ +      "calc" ~: do+        actual <- commute $ calc_ackermann 1000 |$> [0..4] |* 4+        actual @?= [Just 5,Just 6,Just 11,Just 125,Nothing]+    ]++tests_2 :: Test+tests_2 = test [ +      "calc" ~: do+        actual <- commute $ calc_ackermann' 1000 |$> [0..4] |* 4+        actual @?= [Just 5,Just 6,Just 11,Just 125,Nothing]+    ]++tests_3 :: Test+tests_3 = test [ +      "calc" ~: do+        actual <- commute $ calc_ackermann'' 1000 |$> [0..4] |* 4+        actual @?= [Just 5,Just 6,Just 11,Just 125,Nothing]+    ]+

@@ -2,17 +2,19 @@  import DeepControl.Applicative ((|$>)) import DeepControl.Monad (Monad2)-import DeepControl.Monad.Trans (lift, (|*|), (|-*|), (|*-|))-import DeepControl.Monad.Trans.State+import DeepControl.Monad.Morph ((|>|))+import DeepControl.Monad.Trans (liftT, (|*|), (|-*|), (|*-|)) import DeepControl.Monad.Trans.Writer+import DeepControl.Monad.Trans.Identity+import DeepControl.Monad.Trans.State  tick :: State Int () tick = modify (+1) -tock                        ::                   StateT Int IO ()+tock                         ::                   StateT Int IO () tock = do-    (|*|) tick              :: (Monad      m) => StateT Int m  ()-    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()+    (|*|) tick               :: (Monad      m) => StateT Int m  ()+    liftT $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()  -- λ> runStateT tock 0 -- Tock!@@ -21,16 +23,16 @@ save    :: StateT Int (Writer [Int]) () save = do     n <- get-    lift $ tell [n]+    liftT $ tell [n] -program ::                   StateT2 Int IO (Writer [Int]) ()+program ::               StateT Int (IdentityT2 IO (Writer [Int])) () program = replicateM_ 4 $ do-    (|-*|) tock-        :: (Monad2     m) => StateT2 Int IO m              ()-    (|*-|) save-        :: (Monad      m) => StateT2 Int m  (Writer [Int]) ()+    ((|-*|).liftT) |>| tock+        :: (Monad2 m) => StateT Int (IdentityT2 IO m             ) ()+    ((|*-|).liftT) |>| save+        :: (Monad  m) => StateT Int (IdentityT2 m  (Writer [Int])) () --- λ> execWriter |$> runStateT2 program 0+-- λ> execWriter |$> runIdentityT2 (runStateT program 0) -- Tock! -- Tock! -- Tock!@@ -53,7 +55,7 @@         actual @?= ((),1)      , "program" ~: do-        actual <- execWriter |$> runStateT2 program 0+        actual <- execWriter |$> runIdentityT2 (runStateT program 0)         actual @?= [1,2,3,4]     ]