diff --git a/DeepControl/Applicative.hs b/DeepControl/Applicative.hs
--- a/DeepControl/Applicative.hs
+++ b/DeepControl/Applicative.hs
@@ -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))))
diff --git a/DeepControl/Commutative.hs b/DeepControl/Commutative.hs
--- a/DeepControl/Commutative.hs
+++ b/DeepControl/Commutative.hs
@@ -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
diff --git a/DeepControl/Monad.hs b/DeepControl/Monad.hs
--- a/DeepControl/Monad.hs
+++ b/DeepControl/Monad.hs
@@ -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 = 
diff --git a/DeepControl/Monad/Trans.hs b/DeepControl/Monad/Trans.hs
--- a/DeepControl/Monad/Trans.hs
+++ b/DeepControl/Monad/Trans.hs
@@ -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!
diff --git a/DeepControl/Monad/Trans/Except.hs b/DeepControl/Monad/Trans/Except.hs
--- a/DeepControl/Monad/Trans/Except.hs
+++ b/DeepControl/Monad/Trans/Except.hs
@@ -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
diff --git a/DeepControl/Monad/Trans/Identity.hs b/DeepControl/Monad/Trans/Identity.hs
new file mode 100644
--- /dev/null
+++ b/DeepControl/Monad/Trans/Identity.hs
@@ -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
+
+
diff --git a/DeepControl/Monad/Trans/RWS.hs b/DeepControl/Monad/Trans/RWS.hs
--- a/DeepControl/Monad/Trans/RWS.hs
+++ b/DeepControl/Monad/Trans/RWS.hs
@@ -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
 
diff --git a/DeepControl/Monad/Trans/Reader.hs b/DeepControl/Monad/Trans/Reader.hs
--- a/DeepControl/Monad/Trans/Reader.hs
+++ b/DeepControl/Monad/Trans/Reader.hs
@@ -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
 
diff --git a/DeepControl/Monad/Trans/State.hs b/DeepControl/Monad/Trans/State.hs
--- a/DeepControl/Monad/Trans/State.hs
+++ b/DeepControl/Monad/Trans/State.hs
@@ -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
+-}
 
 
diff --git a/DeepControl/Monad/Trans/Writer.hs b/DeepControl/Monad/Trans/Writer.hs
--- a/DeepControl/Monad/Trans/Writer.hs
+++ b/DeepControl/Monad/Trans/Writer.hs
@@ -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)
--}
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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.
 
diff --git a/deepcontrol.cabal b/deepcontrol.cabal
--- a/deepcontrol.cabal
+++ b/deepcontrol.cabal
@@ -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
diff --git a/test/unit_Monad-Level1.hs b/test/unit_Monad-Level1.hs
--- a/test/unit_Monad-Level1.hs
+++ b/test/unit_Monad-Level1.hs
@@ -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
 
 ------------------------------------------------
diff --git a/test/unit_Monad-Level2-2.hs b/test/unit_Monad-Level2-2.hs
deleted file mode 100644
--- a/test/unit_Monad-Level2-2.hs
+++ /dev/null
@@ -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]
-    ]
-
diff --git a/test/unit_Monad-Level2.hs b/test/unit_Monad-Level2.hs
--- a/test/unit_Monad-Level2.hs
+++ b/test/unit_Monad-Level2.hs
@@ -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
     ]
+
 
diff --git a/test/unit_Monad.hs b/test/unit_Monad.hs
--- a/test/unit_Monad.hs
+++ b/test/unit_Monad.hs
@@ -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
 
diff --git a/test/unit_MonadTrans-2.hs b/test/unit_MonadTrans-2.hs
new file mode 100644
--- /dev/null
+++ b/test/unit_MonadTrans-2.hs
@@ -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]
+    ]
+
diff --git a/test/unit_MonadTrans.hs b/test/unit_MonadTrans.hs
--- a/test/unit_MonadTrans.hs
+++ b/test/unit_MonadTrans.hs
@@ -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]
     ]