deepcontrol 0.3.0.0 → 0.3.2.0

raw patch · 29 files changed

+1880/−1143 lines, 29 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• DeepControl/Applicative.hs +52/−34
• DeepControl/Commutative.hs +5/−5
• DeepControl/Monad.hs +8/−8
• DeepControl/Monad/Morph.hs +45/−9
• DeepControl/Monad/Trans.hs +249/−28
• DeepControl/Monad/Trans/Except.hs +46/−0
• DeepControl/Monad/Trans/RWS.hs +40/−7
• DeepControl/Monad/Trans/Reader.hs +40/−7
• DeepControl/Monad/Trans/State.hs +38/−10
• DeepControl/Monad/Trans/Writer.hs +40/−7
• README.md +122/−31
• deepcontrol.cabal +23/−19
• test/UnitTest_Applicative.hs +0/−181
• test/UnitTest_Commutative.hs +0/−30
• test/UnitTest_Monad-Level1.hs +0/−147
• test/UnitTest_Monad-Level2-2.hs +0/−51
• test/UnitTest_Monad-Level2.hs +0/−345
• test/UnitTest_Monad.hs +0/−142
• test/UnitTest_MonadMorph-Level1.hs +0/−60
• test/UnitTest_MonadMorph.hs +0/−22
• test/doctests.hs +3/−0
• test/unit_Applicative.hs +181/−0
• test/unit_Commutative.hs +30/−0
• test/unit_Monad-Level1.hs +147/−0
• test/unit_Monad-Level2-2.hs +87/−0
• test/unit_Monad-Level2.hs +458/−0
• test/unit_Monad.hs +144/−0
• test/unit_MonadMorph.hs +61/−0
• test/unit_MonadTrans.hs +61/−0

@@ -36,7 +36,7 @@     -- ** sequnce notation     (*>>), (<<*),      -- ** sequnce-cover notation-    (*->), (<*-), (-*>), (<-*),+    (-*>), (<-*), (*->), (<*-),       -- * Level-3     -- ** cover notation@@ -73,7 +73,7 @@  import Control.Applicative --- -----------------------------------------------------------------------------+------------------------------------------------------------------------------- -- Level-0 functions  infixl 4  |>, <|@@ -99,7 +99,7 @@ (<|) :: a -> (a -> b) -> b (<|) = flip (|>) --- -----------------------------------------------------------------------------+------------------------------------------------------------------------------- -- Level-1 functions  infixl 6  *:@@ -185,7 +185,7 @@ (*|) :: Applicative f => a -> f (a -> b) -> f b (*|) = flip (|*) --- -----------------------------------------------------------------------------+------------------------------------------------------------------------------- -- Level-2 functions  infixl 6  **:@@ -311,57 +311,75 @@  -- | The lifted function of @'*>'@, defined as @liftA2 (*>)@. ----- >>> ((-*) $ print 1) *>> return [2]+-- >>> sequence $ Just (print 1) *>> (**:) 2 -- 1--- [2]+-- Just 2+--+-- >>> (-*) (print 1) *>> return (Just 2)+-- 1+-- Just 2 (*>>) :: (Applicative f1, Applicative f2) => f1 (f2 a) -> f1 (f2 b) -> f1 (f2 b) (*>>) = liftA2 (*>)  -- | The lifted function of @'<*'@, defined as @liftA2 (<*)@. ----- >>> return [2] <<* ((-*) $ print 1)+-- >>> sequence $ (**:) 2 <<* Just (print 1) -- 1--- [2]--- >>> ((-*) $ print 1) *>> return [3] <<* ((-*) $ print 2)+-- Just 2+-- >>> sequence $ Just (print 1) *>> (**:) 3 <<* Just (print 2) -- 1 -- 2--- [3]+-- Just 3+--+-- >>> sequence $ [putStr "1", putStr "2"] *>> (**:) 0 <<* [putStr "3", putStr "4"]+-- 13142324[0,0,0,0] (<<*) :: (Applicative f1, Applicative f2) => f1 (f2 a) -> f1 (f2 b) -> f1 (f2 a) (<<*) = liftA2 (<*) --- | Combination consisted of sequence @'*>>'@ and cover @'*:'@.------ >>> [1] *-> return [2] --- [2]-(*->) :: (Applicative f1, Applicative f2) => f2 a -> f1 (f2 b) -> f1 (f2 b)-a *-> x = (*:) a *>> x---- | Combination consisted of sequence @'<<*'@ and cover @'*:'@.------ >>> return [2] <*- [1] --- [2]-(<*-) :: (Applicative f1, Applicative f2) => f1 (f2 b) -> f2 a -> f1 (f2 b)-x <*- a = x <<* (*:) a- -- | Combination consisted of sequence @'*>>'@ and cover @'-*'@. ----- >>> print [1] -*> return [2]--- [1]--- [2]+-- >>> print 1 -*> (*:) (Just 2)+-- 1+-- Just 2 (-*>) :: (Applicative f1, Applicative f2) => f1 a -> f1 (f2 b) -> f1 (f2 b) a -*> x = (-*) a *>> x  -- | Combination consisted of sequence @'<<*'@ and cover @'-*'@. ----- >>> return [2] <-* print [1]--- [1]--- [2]--- >>> print [1] -*> return [3] <-* print [2]--- [1]--- [2]--- [3]+-- >>> (*:) (Just 2) <-* print 1+-- 1+-- Just 2+-- >>> print 1 -*> (*:) (Just 3) <-* print 2+-- 1+-- 2+-- Just 3+-- >>> print 1 -*> (*:) (Just 3) <*- Nothing+-- 1+-- Nothing (<-*) :: (Applicative f1, Applicative f2) => f1 (f2 b) -> f1 a -> f1 (f2 b) x <-* a = x <<* (-*) a++-- | Combination consisted of sequence @'*>>'@ and cover @'*:'@.+--+-- >>> sequence $ print 1 *-> Just ((*:) 2)+-- 1+-- Just 2+(*->) :: (Applicative f1, Applicative f2) => f2 a -> f1 (f2 b) -> f1 (f2 b)+a *-> x = (*:) a *>> x++-- | Combination consisted of sequence @'<<*'@ and cover @'*:'@.+--+-- >>> sequence $ Just ((*:) 2) <*- print 1+-- 1+-- Just 2+-- >>> sequence $ print 1 *-> Just ((*:) 3) <*- print 2+-- 1+-- 2+-- Just 3+-- >>> sequence $ print 1 *-> Just ((*:) 3) <-* Nothing+-- Nothing+(<*-) :: (Applicative f1, Applicative f2) => f1 (f2 b) -> f2 a -> f1 (f2 b)+x <*- a = x <<* (*:) a  -- ----------------------------------------------------------------------------- -- Level-3 functions

@@ -31,27 +31,27 @@ -- |  --  class (Functor c) => Commutative c where-  -- | This method is the same for @'Data.Traversable.sequenceA'@ just except the name.+  -- | This method is equivalent for @'Data.Traversable.sequenceA'@ just except the name.   --   The only difference is the name "commute", that is to say from which no action kind of concepts smell.   commute :: Applicative f => c (f a) -> f (c a) --- | Do @fmap f@ then commute, the same for @'Data.Traversable.traverse'@.+-- | Do @fmap f@ then commute, equivalent for @'Data.Traversable.traverse'@. cmap :: (Applicative f, Commutative c) => (a -> f b) -> c a -> f (c b) cmap f = commute . (f |$>)--- | The auguments-flipped function for @'cmap'@, the same for @'Data.Traversable.for'@.+-- | The auguments-flipped function for @'cmap'@, equivalent for @'Data.Traversable.for'@. cfor :: (Applicative f, Commutative c) => c a -> (a -> f b) -> f (c b) cfor = flip cmap  instance Commutative Maybe where     commute (Just fa) = Just |$> fa-    commute Nothing = (*:) Nothing+    commute Nothing   = (*:) Nothing  instance Commutative [] where     commute = foldr (\x acc -> x <$|(:)|*> acc) ((*:) [])    instance Commutative (Either a) where     commute (Right x) = Right |$> x-    commute (Left x) = (*:) $ Left x+    commute (Left x)  = (*:) $ Left x  instance Commutative ((,) a) where     commute (x, y) = x <|(,)|$> y

@@ -202,11 +202,11 @@ -- | The 'Monad3' class defines the Monad functions for level-3 types @m1 (m2 (m3 a)@. --  -- >>> :{--- -- IO-List-List Monad--- [["a","b"]] ->>== \x ->--- [[0],[1,2]] ->>== \y ->--- print (x,y) >--~--- (***:) (x ++ show y)+--  -- IO-List-List Monad+--  [["a","b"]] ->>== \x ->+--  [[0],[1,2]] ->>== \y ->+--  print (x,y) >--~+--  (***:) (x ++ show y) -- :} -- ("a",0) -- ("a",1)@@ -216,7 +216,7 @@ -- ("b",2) -- [["a0","b0"],["a0","b1","b2"],["a1","a2","b0"],["a1","a2","b1","b2"]] ---class (Monad m3) => Monad3 m3 where+class (Monad2 m3) => Monad3 m3 where   (>>>==) :: (Monad m1, Monad2 m2) => m1 (m2 (m3 a)) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))  (>===>) :: (Monad m1, Monad2 m2, Monad3 m3) => (a -> m1 (m2 (m3 b))) -> (b -> m1 (m2 (m3 c))) -> a -> m1 (m2 (m3 c))@@ -274,7 +274,7 @@ infixr 1  >>>>~, >>>>== -- TODO: >>>>~ -class (Monad m4) => Monad4 m4 where+class (Monad3 m4) => Monad4 m4 where   (>>>>==) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 (m4 a))) -> (a -> m1 (m2 (m3 (m4 b)))) -> m1 (m2 (m3 (m4 b)))  (>====>) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => (a -> m1 (m2 (m3 (m4 b)))) -> (b -> m1 (m2 (m3 (m4 c)))) -> a -> m1 (m2 (m3 (m4 c)))@@ -308,7 +308,7 @@ infixr 1  >>>>>~, >>>>>==  -- TODO: >>>>>~ -class (Monad m5) => Monad5 m5 where+class (Monad4 m5) => Monad5 m5 where   (>>>>>==) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 (m5 a)))) -> (a -> m1 (m2 (m3 (m4 (m5 b))))) -> m1 (m2 (m3 (m4 (m5 b))))  (>=====>) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => (a -> m1 (m2 (m3 (m4 (m5 b))))) -> (b -> m1 (m2 (m3 (m4 (m5 c))))) -> a -> m1 (m2 (m3 (m4 (m5 c))))

@@ -1,6 +1,6 @@ {-| Module      : DeepControl.Monad.Morph-Description : +Description : Extension for mmorph's Contrl.Monad.Morph. Copyright   : 2013 Gabriel Gonzalez,               (C) 2015 KONISHI Yohsuke  License     : BSD-style (see the LICENSE file in the distribution)@@ -8,9 +8,14 @@ Stability   : experimental Portability : --- -This module extended mmorph package's Control.Monad.Morph module.+This module enables you to program in Monad-Morphic style for more __deeper__ level than the usual @Control.Monad.Morph@ module expresses.+You would realize exactly what __/more deeper level/__ means by reading the example codes, which are attached on the page bottom.+Note: many instances for Level-4 and Level-5 haven't been written yet. -} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module DeepControl.Monad.Morph (     module Control.Monad.Morph, @@ -23,25 +28,30 @@     -- * Level-3     (|>>>|), (|<<<|), +    -- * Level-4+    (|>>>>|), (|<<<<|),++    -- * Level-5+    (|>>>>>|), (|<<<<<|),+     -- * Level-2 example     -- $Example_Level2      ) where   import DeepControl.Applicative-import DeepControl.Monad.Trans  import Control.Monad.Morph  ------------------------------------------------------------------------------- -- Level-1 functions -infixl 4  |>|+infixl 2  |>| -- | Alias for @'hoist'@. (|>|) :: (Monad m, MFunctor t) => (forall a . m a -> n a) -> t m b -> t n b (|>|) = hoist -infixr 4  |<|+infixr 2  |<| -- | Equivalent to (|>|) with the arguments flipped. (|<|) :: (Monad m, MFunctor t) => t m b -> (forall a . m a -> n a) -> t n b (|<|) l r = hoist r l@@ -49,12 +59,12 @@ ------------------------------------------------------------------------------- -- Level-2 functions -infixl 4  |>>|+infixl 2  |>>| (|>>|) :: (Monad m, Monad (t2 m), MFunctor t1, MFunctor t2) =>            (forall a . m a -> n a) -> t1 (t2 m) b -> t1 (t2 n) b (|>>|) f g = (f |>|) |>| g -infixr 4  |<<|+infixr 2  |<<| (|<<|) :: (Monad m, Monad (t2 m), MFunctor t1, MFunctor t2) =>             t1 (t2 m) b -> (forall a . m a -> n a) -> t1 (t2 n) b (|<<|) f g = (g |>|) |>| f@@ -62,15 +72,41 @@ ------------------------------------------------------------------------------- -- Level-3 functions -infixl 4  |>>>|+infixl 2  |>>>| (|>>>|) :: (Monad m, Monad (t3 m), Monad (t2 (t3 m)), MFunctor t1, MFunctor t2, MFunctor t3) =>             (forall a . m a -> n a) -> t1 (t2 (t3 m)) b -> t1 (t2 (t3 n)) b (|>>>|) f g = (f |>|) |>>| g -infixr 4  |<<<|+infixr 2  |<<<| (|<<<|) :: (Monad m, Monad (t3 m), Monad (t2 (t3 m)), MFunctor t1, MFunctor t2, MFunctor t3) =>             t1 (t2 (t3 m)) b -> (forall a . m a -> n a) -> t1 (t2 (t3 n)) b (|<<<|) f g = (g |>|) |>>| f++-------------------------------------------------------------------------------+-- Level-4 functions++infixl 2  |>>>>|+(|>>>>|) :: (Monad m, Monad (t4 m), Monad (t3 (t4 m)), Monad (t2 (t3 (t4 m))), MFunctor t1, MFunctor t2, MFunctor t3, MFunctor t4) => +            (forall a . m a -> n a) -> t1 (t2 (t3 (t4 m))) b -> t1 (t2 (t3 (t4 n))) b+(|>>>>|) f g = (f |>|) |>>>| g++infixr 2  |<<<<|+(|<<<<|) :: (Monad m, Monad (t4 m), Monad (t3 (t4 m)), Monad (t2 (t3 (t4 m))), MFunctor t1, MFunctor t2, MFunctor t3, MFunctor t4) => +            t1 (t2 (t3 (t4 m))) b -> (forall a . m a -> n a) -> t1 (t2 (t3 (t4 n))) b+(|<<<<|) f g = (g |>|) |>>>| f++-------------------------------------------------------------------------------+-- Level-5 functions++infixl 2  |>>>>>|+(|>>>>>|) :: (Monad m, Monad (t5 m), Monad (t4 (t5 m)), Monad (t3 (t4 (t5 m))), Monad (t2 (t3 (t4 (t5 m)))), MFunctor t1, MFunctor t2, MFunctor t3, MFunctor t4, MFunctor t5) => +             (forall a . m a -> n a) -> t1 (t2 (t3 (t4 (t5 m)))) b -> t1 (t2 (t3 (t4 (t5 n)))) b+(|>>>>>|) f g = (f |>|) |>>>>| g++infixr 2  |<<<<<|+(|<<<<<|) :: (Monad m, Monad (t5 m), Monad (t4 (t5 m)), Monad (t3 (t4 (t5 m))), Monad (t2 (t3 (t4 (t5 m)))), MFunctor t1, MFunctor t2, MFunctor t3, MFunctor t4, MFunctor t5) => +             t1 (t2 (t3 (t4 (t5 m)))) b -> (forall a . m a -> n a) -> t1 (t2 (t3 (t4 (t5 n)))) b+(|<<<<<|) f g = (g |>|) |>>>>| f  ------------------------------------------------------------------------------- -- TODO

@@ -11,60 +11,231 @@  This module enables you to program in Monad-Transformer style for more __deeper__ level than the usual @Control.Monad.Trans@ module expresses. You would realize exactly what __/more deeper level/__ means by reading the example codes, which are attached on the page bottom.-Note: all the MonadTransx instances for Level-4 and Level-5 haven't been written yet.+Note: many instances for Level-4 and Level-5 haven't been written yet. -}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} module DeepControl.Monad.Trans (     -- * MonadIO     MonadIO(..),      -- * MonadTrans-    trans,-    MonadTrans(..),-    MonadTrans2(..),-    MonadTrans3(..),+    -- ** Level-1+    MonadTrans(..), +    MonadTransDown(..), M,+    -- *** cover functions +    MonadTransCover(..),+    -- *** other  +    MonadTrans_(..), ++    -- ** Level-2+    MonadTrans2(..), +    MonadTrans2Down(..), M_, T_, +    -- *** fold functions+    MonadTransFold2(..), +    -- *** cover functions +    MonadTransCover2(..),+    (|**|),+    -- *** other  +    trans2, untrans2, ++    -- ** Level-3+    MonadTrans3(..), +    MonadTrans3Down(..), M__, T__, +    -- *** fold functions+    MonadTransFold3(..), +    -- *** cover functions+    MonadTransCover3(..),+    (|***|), (|-**|), (|*-*|), (|**-|),+    -- *** other  +    trans3, untrans3, ++    -- ** Level-4     MonadTrans4(..),++    -- ** Level-5     MonadTrans5(..),      -- * Level-2 example     -- $Example_Level2 +    -- * Level-2 example2+    -- $Example_Level2_cover+ ) where -import           DeepControl.Monad+import DeepControl.Applicative+import DeepControl.Monad -import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (MonadTrans (..))+import qualified Control.Monad.List          as L+import qualified Control.Monad.Trans.Maybe   as M+import qualified Control.Monad.Except        as E+import Control.Monad.Identity  ---------------------------------------------------------------------- -- Level-1 --- | Alias for @'Control.Monad.Trans.Class.lift'@.-trans :: (Monad m, MonadTrans t) => m a -> t m a-trans = lift+class (Monad (TransDown t1), MonadTrans t1) => MonadTransDown t1 where+    type TransDown t1 :: * -> *+type M t1 = TransDown t1 +instance MonadTransDown L.ListT where+    type TransDown L.ListT = []+instance MonadTransDown M.MaybeT where+    type TransDown M.MaybeT = Maybe+instance MonadTransDown (E.ExceptT e) where+    type TransDown (E.ExceptT e) = E.Except e++{-+class (MonadTrans t) => MonadTransFold t where+    transfold :: (Monad m1) => +                  m1 a -> t m1 a+-}++infixl 3  |*|++class (MonadTransDown t1) => MonadTransCover t1 where+    (|*|) :: Monad m1 => (TransDown t1) a -> t1 m1 a++instance MonadTransCover L.ListT where+    (|*|) = L.ListT . (*:)+instance MonadTransCover M.MaybeT where+    (|*|) = M.MaybeT . (*:)+instance MonadTransCover (E.ExceptT e) where+    (|*|) = E.ExceptT . (*:) . E.runExcept++-- | Required only for @'MonadTransFold2'@ and @'MonadTransFold3'@ +class MonadTrans_ t1 where+    trans :: (Monad m2) => m2 ((TransDown t1) a) -> t1 m2 a+    untrans :: (Monad m2) => t1 m2 a -> m2 ((TransDown t1) a)++instance MonadTrans_ L.ListT where+    trans   = L.ListT+    untrans = L.runListT+instance MonadTrans_ M.MaybeT where+    trans   = M.MaybeT+    untrans = M.runMaybeT+instance MonadTrans_ (E.ExceptT e) where+    untrans x = (E.ExceptT . Identity) |$> E.runExceptT x+    trans x   = E.ExceptT ((runIdentity . E.runExceptT) |$> x)+ ---------------------------------------------------------------------- -- Level-2 -class  MonadTrans2 t  where-    trans2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a+class MonadTrans2 t where+    lift2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a +class (MonadTrans (Trans2Down t2), MonadTrans2 t2) => MonadTrans2Down t2 where+    type Trans2Down t2 :: (* -> *) -> * -> *+type M_ t2 = TransDown (Trans2Down t2)+type T_ t2 = Trans2Down t2+++-- | +--+-- Following property holds.+--+-- > untransfold2 . transfold2 == id+class (MonadTrans (T_ t), MonadTrans2 t) => MonadTransFold2 t where+    transfold2 :: (Monad m1, Monad (t2 m1), +                   MonadTrans_ t2) => +                  t m1 (TransDown t2) a -> (T_ t) (t2 m1) a+    untransfold2 :: (Monad m1, Monad (t2 m1), +                     MonadTrans_ t2) => +                    (T_ t) (t2 m1) a -> t m1 (TransDown t2) a++infixl 3  |-*|, |*-|, |**|++class (MonadTransCover (Trans2Down t2)) => MonadTransCover2 t2 where+    (|-*|) :: (Monad m1, Monad2 m2) => (Trans2Down t2) m1 a -> t2 m1 m2 a+    (|*-|) :: (Monad m1, Monad2 m2) => (Trans2Down t2) m2 a -> t2 m1 m2 a++(|**|) :: (Monad m1, Monad2 m2, MonadTransCover2 t2) => +          (M_ t2) a -> t2 m1 m2 a+(|**|) = (|*-|) . (|*|) ++trans2 :: (Monad m1, Monad (t2 m1), +           MonadTrans_ t2, MonadTrans_ t3) =>+           m1 ((TransDown t2) ((TransDown t3) a)) -> t3 (t2 m1) a+trans2 = trans . trans+untrans2 :: (Monad m1, Monad (t2 m1), +             MonadTrans_ t2, MonadTrans_ t3) =>+             t3 (t2 m1) a -> m1 ((TransDown t2) ((TransDown t3) a))+untrans2 = untrans . untrans+ ---------------------------------------------------------------------- -- Level-3 -class  MonadTrans3 t  where-    trans3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a+class MonadTrans3 t where+    lift3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a +class (MonadTrans2 (Trans3Down t3), MonadTrans3 t3) => MonadTrans3Down t3 where+    type Trans3Down t3 :: (* -> *) -> (* -> *) -> * -> *+type M__ t3 = M_ (Trans3Down t3)+type T__ t3 = T_ (Trans3Down t3)++-- | +--+-- Following property holds.+--+-- > untransfold3 . transfold3 == id+class (MonadTrans (T__ t), MonadTrans3 t) => MonadTransFold3 t where+    transfold3 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)), +                   MonadTrans t3, MonadTrans t2, +                   MonadTrans_ t2, MonadTrans_ t3) => +                  t m1 (TransDown t2) (TransDown t3) a -> (T__ t) (t3 (t2 m1)) a+    untransfold3 :: (Monad m1, Monad (t2 m1), Monad (t3 (t2 m1)), +                     MonadTrans t3, MonadTrans t2, +                     MonadTrans_ t2, MonadTrans_ t3) => +                    (T__ t) (t3 (t2 m1)) a -> t m1 (TransDown t2) (TransDown t3) a++infixl 3  |--*|, |-*-|, |*--|, |***|, |-**|, |*-*|, |**-|++class (MonadTransCover2 (Trans3Down t3)) => MonadTransCover3 t3 where+    (|--*|) :: (Monad m1, Monad2 m2, Monad3 m3) => (Trans3Down t3) m1 m2 a -> t3 m1 m2 m3 a+    (|-*-|) :: (Monad m1, Monad2 m2, Monad3 m3) => (Trans3Down t3) m1 m3 a -> t3 m1 m2 m3 a+    (|*--|) :: (Monad m1, Monad2 m2, Monad3 m3) => (Trans3Down t3) m2 m3 a -> t3 m1 m2 m3 a++(|***|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) => +           (M__ t3) a -> t3 m1 m2 m3 a+(|***|) = (|*--|) . (|**|)+(|-**|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) => +           (T__ t3) m1 a -> t3 m1 m2 m3 a+(|-**|) = (|--*|) . (|-*|)+(|*-*|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) => +           (T__ t3) m2 a -> t3 m1 m2 m3 a+(|*-*|) = (|--*|) . (|*-|)+(|**-|) :: (Monad m1, Monad2 m2, Monad3 m3, MonadTransCover3 t3) => +           (T__ t3) m3 a -> t3 m1 m2 m3 a+(|**-|) = (|*--|) . (|*-|)++trans3 :: (Monad m1, Monad (t3 (t2 m1)), Monad (t2 m1),+           MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4) =>+           m1 ((TransDown t2) ((TransDown t3) ((TransDown t4) a))) -> t4 (t3 (t2 m1)) a+trans3 = trans2 . trans+untrans3 :: (Monad m1, Monad (t3 (t2 m1)), Monad (t2 m1),+           MonadTrans_ t2, MonadTrans_ t3, MonadTrans_ t4) =>+           t4 (t3 (t2 m1)) a -> m1 ((TransDown t2) ((TransDown t3) ((TransDown t4) a)))+untrans3 = untrans2 . untrans++ ---------------------------------------------------------------------- -- Level-4  class  MonadTrans4 t  where-    trans4 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 a))) -> t m1 m2 m3 m4 a+    lift4 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 a))) -> t m1 m2 m3 m4 a  ---------------------------------------------------------------------- -- Level-5 -class  MonadTrans5 t  where-    trans5 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => m1 (m2 (m3 (m4 (m5 a)))) -> t m1 m2 m3 m4 m5 a+class MonadTrans5 t where+    lift5 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => m1 (m2 (m3 (m4 (m5 a)))) -> t m1 m2 m3 m4 m5 a  ---------------------------------------------------------------------- -- Examples@@ -75,31 +246,81 @@ >import DeepControl.Applicative >import DeepControl.Commutative (commute) >import DeepControl.Monad ((>-))->import DeepControl.Monad.Trans (trans2)+>import DeepControl.Monad.Trans (lift2, transfold2, untransfold2) >import DeepControl.Monad.Trans.Reader+>import Control.Monad.Trans.Maybe > >import System.Timeout (timeout) > >type TimeLimit = Int >->ackermann :: TimeLimit -> Int -> Int ->->             IO (Maybe Int)                        -- IO-Maybe Monad->ackermann timelimit x y = timeout timelimit (ackermannIO x y)+>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)->->ackermannR :: Int -> Int ->->              ReaderT2 TimeLimit IO Maybe Int      -- ReaderT2-IO-Maybe monad->ackermannR x y = do+> +>ackermann :: Int -> Int -> +>               ReaderT2 TimeLimit IO Maybe Int      -- ReaderT2-IO-Maybe monad+>ackermann x y = do >    timelimit <- ask->    trans2 $ ackermann timelimit x y               -- transform(lift) IO-Maybe function to ReaderT2-IO-Maybe function+>    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 = ackermannR x y >- \r -> runReaderT2 r timelimit+>calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT2 r timelimit > >-- λ> commute $ calc_ackermann 1000 |$> [0..4] |* 4 >-- [Just 5,Just 6,Just 11,Just 125,Nothing]+>+>ackermann' :: Int -> Int -> +>              ReaderT TimeLimit (MaybeT IO) Int     -- ReaderT-MaybeT-IO monad+>ackermann' x y = transfold2 $ ackermann x y         -- You can get usual ReaderT-MaybeT-IO function from ReaderT2-IO-Maybe function+>+>ackermann'' :: Int -> Int -> +>               ReaderT2 TimeLimit IO Maybe Int      -- ReaderT2-IO-Maybe monad+>ackermann'' x y = untransfold2 $ ackermann' x y     -- You can get ReaderT2-IO-Maybe function from usual ReaderT-MaybeT-IO function+-}++{- $Example_Level2_cover+Here is a monad transformer example showing how to use cover functions.++>import DeepControl.Applicative ((|$>))+>import DeepControl.Monad (Monad2)+>import DeepControl.Monad.Trans (lift, (|*|), (|-*|), (|*-|))+>import DeepControl.Monad.Trans.State+>import DeepControl.Monad.Trans.Writer+>+>tick :: State Int ()+>tick = modify (+1)+>+>tock                        ::                   StateT Int IO ()+>tock = do+>    (|*|) tick              :: (Monad      m) => StateT Int m  ()+>    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()+>+>-- λ> runStateT tock 0+>-- Tock!+>-- ((),1)+>+>save    :: StateT Int (Writer [Int]) ()+>save = do+>    n <- get+>    lift $ tell [n]+>+>program ::                   StateT2 Int IO (Writer [Int]) ()+>program = replicateM_ 4 $ do+>    (|-*|) tock+>        :: (Monad2     m) => StateT2 Int IO m              ()+>    (|*-|) save+>        :: (Monad      m) => StateT2 Int m  (Writer [Int]) ()+>+>-- λ> execWriter |$> runStateT2 program 0+>-- Tock!+>-- Tock!+>-- Tock!+>-- Tock!+>-- [1,2,3,4] -}

@@ -0,0 +1,46 @@+{-|+Module      : DeepControl.Monad.Except+Description : Extension for mtl's Contrl.Monad.Except.+Copyright   : (C) 2013 Ross Paterson,+              (C) 2015 KONISHI Yohsuke +License     : BSD-style (see the file LICENSE)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module extended RWS Monad in mtl(monad-transformer-library).+-}+{-# LANGUAGE +        DeriveFunctor,+        GeneralizedNewtypeDeriving,+        FlexibleInstances,+        FunctionalDependencies+ #-}+module DeepControl.Monad.Trans.Except (+    module Control.Monad.Except,++    ) where ++import DeepControl.Applicative+import DeepControl.Monad+-- import DeepControl.Monad.Trans+import DeepControl.Commutative++import Control.Monad.Except+import Control.Monad.Identity++----------------------------------------------------------------+--++instance Monad2 (Except e) where+    m >>== f = (ExceptT . Identity |$>) $ (runExcept |$> m) >>== runExcept |$>> f+instance Monad3 (Except e) where+    m >>>== f = (ExceptT . Identity |$>>) $ (runExcept |$>> m) >>>== runExcept |$>>> f+instance Monad4 (Except e) where+    m >>>>== f = (ExceptT . Identity |$>>>) $ (runExcept |$>>> m) >>>>== runExcept |$>>>> f+instance Monad5 (Except e) where+    m >>>>>== f = (ExceptT . Identity |$>>>>) $ (runExcept |$>>>> m) >>>>>== runExcept |$>>>>> f++instance Commutative (Except e) where+    commute x = ExceptT . Identity |$> commute (runExcept $ x)+

@@ -1,6 +1,6 @@ {-| Module      : DeepControl.Monad.Trans.RWS-Description : +Description : Extension for mtl's Contrl.Monad.RWS. Copyright   : (C) 2015 KONISHI Yohsuke,               (c) Andy Gill 2001,               (c) Oregon Graduate Institute of Science and Technology, 2001@@ -11,8 +11,9 @@  This module extended RWS Monad in mtl(monad-transformer-library). -}-{-# LANGUAGE MultiParamTypeClasses, -             FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} module DeepControl.Monad.Trans.RWS (     module Control.Monad.RWS,     MonadReader(..), MonadWriter(..), MonadState(..),@@ -36,6 +37,15 @@ import Data.Monoid  ----------------------------------------------------------------------+-- Level-1++instance (Monoid w) => MonadTransDown (RWST r w s) where+    type TransDown (RWST r w s) = RWS r w s++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)) }@@ -69,11 +79,11 @@     put s = RWST2 $ \_ _ -> (**:) ((), s, mempty)  instance (Monoid w) => MonadTrans2 (RWST2 r w s) where-    trans2 m = RWST2 $ \r s -> +    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 = trans2 . (-*) . liftIO+    liftIO = lift2 . (-*) . liftIO  rwsT2 :: (Monad m1, Monad2 m2) => (r -> s -> (a, s, w)) -> RWST2 r w s m1 m2 a rwsT2 = RWST2 . ((**:)|$>>)@@ -91,6 +101,17 @@ 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) +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+ ---------------------------------------------------------------------- -- Level-3 @@ -125,11 +146,11 @@     put s = RWST3 $ \_ _ -> (***:) ((), s, mempty)  instance (Monoid w) => MonadTrans3 (RWST3 r w s) where-    trans3 m = RWST3 $ \r s -> +    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 = trans3 . (-**) . liftIO+    liftIO = lift3 . (-**) . liftIO  rwsT3 :: (Monad m1, Monad2 m2, Monad3 m3) => (r -> s -> (a, s, w)) -> RWST3 r w s m1 m2 m3 a rwsT3 = RWST3 . ((***:)|$>>)@@ -146,4 +167,16 @@ 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)++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 

@@ -1,6 +1,6 @@ {-| Module      : DeepControl.Monad.Trans.Reader-Description : +Description : Extension for mtl's Contrl.Monad.Reader. Copyright   : (c) Andy Gill 2001,               (c) Oregon Graduate Institute of Science and Technology 2001,               (c) Jeff Newbern 2003-2007,@@ -13,8 +13,9 @@  This module extended Reader Monad in mtl(monad-transformer-library). -}-{-# LANGUAGE MultiParamTypeClasses, -             FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} module DeepControl.Monad.Trans.Reader (     module Control.Monad.Reader, @@ -33,6 +34,15 @@ import Control.Monad.Signatures  ----------------------------------------------------------------------+-- Level-1++instance MonadTransDown (ReaderT r) where+    type TransDown (ReaderT r) = Reader r++instance MonadTransCover (ReaderT s) where+    (|*|) = ReaderT . ((*:)|$>) . runReader++---------------------------------------------------------------------- -- Level-2  newtype ReaderT2 r m1 m2 a = ReaderT2 { runReaderT2 :: r -> m1 (m2 a) }@@ -53,15 +63,26 @@     local f m = ReaderT2 $ runReaderT2 m . f  instance MonadTrans2 (ReaderT2 r) where-    trans2 m = ReaderT2 $ \r -> +    lift2 m = ReaderT2 $ \r ->          m >>== \a ->         (**:) a instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (ReaderT2 r m1 m2) where-    liftIO = trans2 . (-*) . liftIO+    liftIO = lift2 . (-*) . liftIO  mapReaderT2 :: (m1 (m2 a) -> n1 (n2 b)) -> ReaderT2 r m1 m2 a -> ReaderT2 r n1 n2 b mapReaderT2 f m = ReaderT2 $ f . runReaderT2 m +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+ ---------------------------------------------------------------------- -- Level-3 @@ -83,12 +104,24 @@     local f m = ReaderT3 $ runReaderT3 m . f  instance MonadTrans3 (ReaderT3 r) where-    trans3 m = ReaderT3 $ \r -> +    lift3 m = ReaderT3 $ \r ->          m >>>== \a ->         (***:) a instance (MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (ReaderT3 r m1 m2 m3) where-    liftIO = trans3 . (-**) . liftIO+    liftIO = lift3 . (-**) . liftIO  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++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 

@@ -1,6 +1,7 @@+{-# LANGUAGE TypeFamilies #-} {-| Module      : DeepControl.Monad.Trans.State-Description : +Description : Extension for mtl's Contrl.Monad.State. Copyright   : (c) Andy Gill 2001,               (c) Oregon Graduate Institute of Science and Technology, 2001,               (C) 2015 KONISHI Yohsuke,@@ -11,9 +12,9 @@  This module extended State Monad in mtl(monad-transformer-library). -}-{-# LANGUAGE MultiParamTypeClasses,-             FlexibleInstances,-             UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} module DeepControl.Monad.Trans.State (     module Control.Monad.State, @@ -32,6 +33,15 @@ import Control.Monad.Signatures  ----------------------------------------------------------------------+-- Level-1++instance MonadTransDown (StateT s) where+    type TransDown (StateT s) = State s++instance MonadTransCover (StateT s) where+    (|*|) = StateT . ((*:)|$>) . runState++---------------------------------------------------------------------- -- Level-2  newtype StateT2 s m1 m2 a = StateT2 { runStateT2 :: (s -> m1 (m2 (a,s))) }@@ -53,11 +63,11 @@     put s = StateT2 $ \_ -> (**:) ((), s)  instance MonadTrans2 (StateT2 s) where-    trans2 m = StateT2 $ \s -> +    lift2 m = StateT2 $ \s ->          m >>== \a ->         (**:) (a, s) instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (StateT2 s m1 m2) where-    liftIO = trans2 . (-*) . liftIO+    liftIO = lift2 . (-*) . liftIO  evalStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 a) evalStateT2 m s = @@ -73,6 +83,17 @@ withStateT2 :: (s -> s) -> StateT2 s m1 m2 a -> StateT2 s m1 m2 a withStateT2 f m = StateT2 $ runStateT2 m . f +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+ ---------------------------------------------------------------------- -- Level-3 @@ -95,11 +116,11 @@     put s = StateT3 $ \_ -> (***:) ((), s)  instance MonadTrans3 (StateT3 s) where-    trans3 m = StateT3 $ \s -> +    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 = trans3 . (-**) . liftIO+    liftIO = lift3 . (-**) . liftIO  evalStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 a)) evalStateT3 m s = @@ -115,8 +136,15 @@ withStateT3 :: (s -> s) -> StateT3 s m1 m2 m3 a -> StateT3 s m1 m2 m3 a withStateT3 f m = StateT3 $ runStateT3 m . f --+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 

@@ -1,6 +1,6 @@ {-| Module      : DeepControl.Monad.Trans.State-Description : +Description : Extension for mtl's Contrl.Monad.Writer. Copyright   : (c) Andy Gill 2001,               (c) Oregon Graduate Institute of Science and Technology, 2001,               (C) 2015 KONISHI Yohsuke,@@ -11,8 +11,9 @@  This module extended Writer Monad in mtl(monad-transformer-library). -}-{-# LANGUAGE MultiParamTypeClasses, -             FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} module DeepControl.Monad.Trans.Writer (     module Control.Monad.Writer, @@ -56,6 +57,16 @@         f a <<<<$| (\x -> runWriterT x >- \(Identity (b, w')) ->                           WriterT $ Identity (b, w <> w')) +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 @@ -83,11 +94,11 @@         (**:) (a, f w)  instance (Monoid w) => MonadTrans2 (WriterT2 w) where-    trans2 m = WriterT2 $ +    lift2 m = WriterT2 $          m >>== \a ->         (**:) (a, mempty) instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (WriterT2 w m1 m2) where-    liftIO = trans2 . (-*) . liftIO+    liftIO = lift2 . (-*) . liftIO  execWriterT2 :: (Monad m1, Monad2 m2) => WriterT2 w m1 m2 a -> m1 (m2 w) execWriterT2 m =@@ -97,6 +108,17 @@ 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) +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+ ---------------------------------------------------------------------- -- Level-3 @@ -124,11 +146,11 @@         (***:) (a, f w)  instance (Monoid w) => MonadTrans3 (WriterT3 w) where-    trans3 m = WriterT3 $ +    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 = trans3 . (-**) . liftIO+    liftIO = lift3 . (-**) . liftIO  execWriterT3 :: (Monad m1, Monad2 m2, Monad3 m3) => WriterT3 w m1 m2 m3 a -> m1 (m2 (m3 w)) execWriterT3 m =@@ -138,4 +160,15 @@ 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) +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 

@@ -62,13 +62,13 @@ ### Fetch from [Hackage](https://hackage.haskell.org/package/deepcontrol)  Ok, I(you) got `deepcontrol` isn't in Stackage. Then let's fetch `deepcontrol` from Hackage.-Add `deepcontrol-0.3.0.0` to your extra-deps field in stack.yaml too:+Add `deepcontrol-0.3.2.0` to your extra-deps field in stack.yaml too:  stack.yaml:      extra-deps:     ...-    - deepcontrol-0.3.0.0+    - deepcontrol-0.3.2.0  And type as below: @@ -77,7 +77,7 @@ Stack must fetch and install `deepcontrol` automatically.      ../yourproject$ stack build-    deepcontrol-0.3.0.0: configure+    deepcontrol-0.3.2.0: configure     ...  Now start ghci and see if it works well.@@ -119,7 +119,7 @@  ## Examples -### [Applicative](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Applicative.html)+### [Applicative](https://hackage.haskell.org/package/deepcontrol-0.3.2.0/docs/DeepControl-Applicative.html)  This module enables you to program in applicative style for more deeper level than the usual Applicative module expresses. You would soon realize exactly what more deeper level means by reading the example codes below in order.@@ -258,7 +258,7 @@  Not completely written up yet. -### [Monad](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Monad.html)+### [Monad](https://hackage.haskell.org/package/deepcontrol-0.3.2.0/docs/DeepControl-Monad.html)  This module enables you to program in Monad for more deeper level than the usual Monad module expresses. You would soon realize exactly what more deeper level means by reading the example codes below in order.@@ -286,11 +286,10 @@ factorial :: Int ->              Maybe (Writer [Int] Int)  -- Maybe-Writer Monad factorial n | n < 0  = (-*) Nothing-factorial n | n == 0 = (*:) $ tell [0] >> return 1-factorial n | n > 0  =-    factorial (n-1) >>== \v ->-    tell [v] ->~-    (**:) (n * v)+            | n == 0 = (*:) $ tell [0] >> return 1+            | n > 0  = factorial (n-1) >>== \v ->+                       tell [v] ->~+                       (**:) (n * v)  -- > runWriter |$> factorial 5 -- Just (120,[0,1,1,2,6,24])@@ -306,15 +305,13 @@ factorial :: Int ->              IO (Maybe (Writer [Int] Int))    -- IO-Maybe-Writer Monad factorial n | n < 0  = (*-*) Nothing-factorial n | n == 0 = (**:) $ tell [0] >> return 1-factorial n | n > 0  =-    factorial (n-1) >>>== \v ->-    print v >--~-    tell [v] -->~-    (***:) (n * v)+            | n == 0 = (**:) $ tell [0] >> return 1+            | n > 0  = factorial (n-1) >>>== \v ->+                       print v >--~+                       tell [v] -->~+                       (***:) (n * v) --- > runWriter |$>> factorial--- 0+-- > runWriter |$>> factorial 5 -- 1 -- 1 -- 2@@ -322,7 +319,7 @@ -- 24 -- Just (120,[0,1,1,2,6,24]) ```-### [Monad-Transformer](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Monad-Trans.html)+### [Monad-Transformer](https://hackage.haskell.org/package/deepcontrol-0.3.2.0/docs/DeepControl-Monad-Trans.html)  #### Level-2 @@ -332,37 +329,131 @@ import DeepControl.Applicative import DeepControl.Commutative (commute) import DeepControl.Monad ((>-))-import DeepControl.Monad.Trans (trans2)+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 -> 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)--ackermannR :: Int -> Int ->-              ReaderT2 TimeLimit IO Maybe Int        -- ReaderT2-IO-Maybe monad-ackermannR x y = do+ +ackermann :: Int -> Int -> +               ReaderT2 TimeLimit IO Maybe Int      -- ReaderT2-IO-Maybe monad+ackermann x y = do     timelimit <- ask-    trans2 $ ackermannTimeLimit timelimit x y        -- transform(lift) IO-Maybe function to ReaderT2-IO-Maybe function+    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 = ackermannR x y >- \r -> runReaderT2 r timelimit+calc_ackermann timelimit x y = ackermann x y >- \r -> runReaderT2 r timelimit  -- λ> commute $ calc_ackermann 1000 |$> [0..4] |* 4 -- [Just 5,Just 6,Just 11,Just 125,Nothing]++ackermann' :: Int -> Int -> +              ReaderT TimeLimit (MaybeT IO) Int     -- ReaderT-MaybeT-IO monad+ackermann' x y = transfold2 $ ackermann x y         -- You can get usual ReaderT-MaybeT-IO function from ReaderT2-IO-Maybe function++ackermann'' :: Int -> Int -> +               ReaderT2 TimeLimit IO Maybe Int      -- ReaderT2-IO-Maybe monad+ackermann'' x y = untransfold2 $ ackermann' x y     -- You can get ReaderT2-IO-Maybe function from usual ReaderT-MaybeT-IO function ``` -### [Monad-Morph](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Monad-Morph.html)+Here is a monad transformer example showing that the Monad Morphic programming is usable. -### [Commutative](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Commutative.html)+```haskell+import DeepControl.Applicative ((|$>))+import DeepControl.Monad (Monad2)+import DeepControl.Monad.Trans (lift, (|*|), (|-*|), (|*-|))+import DeepControl.Monad.Trans.State+import DeepControl.Monad.Trans.Writer -### [Arrow](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Arrow.html)+tick :: State Int ()+tick = modify (+1)++tock                        ::                   StateT Int IO ()+tock = do+    (|*|) tick              :: (Monad      m) => StateT Int m  ()+    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()++-- λ> runStateT tock 0+-- Tock!+-- ((),1)++save    :: StateT Int (Writer [Int]) ()+save = do+    n <- get+    lift $ tell [n]++program ::                   StateT2 Int IO (Writer [Int]) ()+program = replicateM_ 4 $ do+    (|-*|) tock+        :: (Monad2     m) => StateT2 Int IO m              ()+    (|*-|) save+        :: (Monad      m) => StateT2 Int m  (Writer [Int]) ()++-- λ> execWriter |$> runStateT2 program 0+-- Tock!+-- Tock!+-- Tock!+-- Tock!+-- [1,2,3,4]+```+#### Level-3++Work well likewise.++### [Monad-Morph](https://hackage.haskell.org/package/deepcontrol-0.3.2.0/docs/DeepControl-Monad-Morph.html)++Here is a monad-morph example, a level-2 monad-morph.++```haskell+import DeepControl.Monad.Morph+import DeepControl.Monad.Trans.State+import DeepControl.Monad.Trans.Writer++-- i.e. :: StateT Int Identity ()+tick    :: State Int ()+tick = modify (+1)++tock                        ::                   StateT Int IO ()+tock = do+    generalize |>| tick     :: (Monad      m) => StateT Int m  ()+    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()++-- λ> runStateT tock 0+-- Tock!+-- ((),1)++-- i.e. :: StateT Int (WriterT [Int] Identity) ()+save    :: StateT Int (Writer  [Int]) ()+save = do+    n <- get+    lift $ tell [n]++program ::                   StateT Int (WriterT [Int] IO) ()+program = replicateM_ 4 $ do+    lift |>| tock+        :: (MonadTrans t) => StateT Int (t             IO) ()+    generalize |>>| save+        :: (Monad      m) => StateT Int (WriterT [Int] m ) ()++-- λ> execWriterT (runStateT program 0)+-- Tock!+-- Tock!+-- Tock!+-- Tock!+-- [1,2,3,4]+```++### [Commutative](https://hackage.haskell.org/package/deepcontrol-0.3.2.0/docs/DeepControl-Commutative.html)++### [Arrow](https://hackage.haskell.org/package/deepcontrol-0.3.2.0/docs/DeepControl-Arrow.html)

@@ -1,7 +1,7 @@ name:                deepcontrol-version:             0.3.0.0-synopsis:            Enable 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 provides, especially for Applicative and Monad.+version:             0.3.2.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 license-file:        LICENSE author:              KONISHI Yohsuke@@ -27,6 +27,7 @@                      , DeepControl.Monad                      , DeepControl.Monad.Morph                      , DeepControl.Monad.Trans+                     , DeepControl.Monad.Trans.Except                      , DeepControl.Monad.Trans.RWS                      , DeepControl.Monad.Trans.Reader                      , DeepControl.Monad.Trans.State@@ -38,6 +39,9 @@                      , DeriveFunctor                      , GeneralizedNewtypeDeriving                      , FunctionalDependencies+                     , TypeSynonymInstances+                     , TypeFamilies+                     , FlexibleContexts   build-depends:       base >=4.8 && <5                      , mtl >=2.2                      , mmorph >= 1.0@@ -56,81 +60,81 @@                       , doctest >= 0.9.3                       , QuickCheck >= 2.8.1 -Test-Suite UnitTest_Applicative+Test-Suite unit_Applicative   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_Applicative.hs+  Main-Is:              unit_Applicative.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , deepcontrol-Test-Suite UnitTest_Commutative+Test-Suite unit_Commutative   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_Commutative.hs+  Main-Is:              unit_Commutative.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , deepcontrol-Test-Suite UnitTest_Monad+Test-Suite unit_Monad   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_Monad.hs+  Main-Is:              unit_Monad.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , deepcontrol                       , mtl                       , safe-Test-Suite UnitTest_Monad-Level1+Test-Suite unit_Monad-Level1   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_Monad-Level1.hs+  Main-Is:              unit_Monad-Level1.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , mtl, containers                       , deepcontrol-Test-Suite UnitTest_Monad-Level2+Test-Suite unit_Monad-Level2   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_Monad-Level2.hs+  Main-Is:              unit_Monad-Level2.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , mtl, transformers                       , deepcontrol-Test-Suite UnitTest_Monad-Level2-2+Test-Suite unit_Monad-Level2-2   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_Monad-Level2-2.hs+  Main-Is:              unit_Monad-Level2-2.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , mtl, transformers                       , deepcontrol-Test-Suite UnitTest_MonadMorph+Test-Suite unit_MonadTrans   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_MonadMorph.hs+  Main-Is:              unit_MonadTrans.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , mtl                       , deepcontrol-Test-Suite UnitTest_MonadMorph-Level1+Test-Suite unit_MonadMorph   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test   -- Ghc-Options:          -threaded -Wall-  Main-Is:              UnitTest_MonadMorph-Level1.hs+  Main-Is:              unit_MonadMorph.hs   Build-Depends:        base                       , HUnit >= 1.3.0                       , mtl

@@ -1,181 +0,0 @@-import Test.HUnit--import DeepControl.Applicative--main :: IO ()-main = run >> return ()---- | Run Unit-Test of this module. -run = runTestTT $ TestList -        [ TestList tLevel0-        , TestList tLevel1-        , TestList tLevel2-        , TestList tLevel3--        ]--------------------------------------------------------------------- unit test-------------------------------------------------------------------tLevel0 = ("Level0" ~:) |$> [ -      TestList $ ("|>" ~:) |$> [ -          (1+) |> 2  ~?= 3-        , (1:) |> [] ~?= [1]-        , ("a"++) |> "b" ~?= "ab"-        , (True &&) |> False ~?= False-        , (True ||) |> False ~?= True-        ]--    , TestList $ ("<|" ~:) |$> [ -          1 <| (+2)  ~?= 3-        , 1 <| (:[]) ~?= [1]-        , "a" <| (++"b")  ~?= "ab"-        , True <| (&& False) ~?= False-        , True <| (|| False) ~?= True-        ]--    , TestList $ ("<| and |>" ~:) |$> [ -          1 <|(+)|> 2               ~?= 3-        , 1 <|(+)|> 2 <|(-)|> 3     ~?= 0-        , 1 <|(+)|> 2 <|(*)|> 3     ~?= 9--        , 1 <|(:)|> []             ~?= [1]-        , 1 <|(:)|> (2 <|(:)|> []) ~?= [1,2]--        , "a" <|(++)|> "b"              ~?= "ab"-        , "a" <|(++)|> "b" <|(++)|> "c" ~?= "abc"--        , True <|(&&)|> False ~?= False-        , True <|(||)|> False ~?= True--        , 1 <|(,)|> 2             ~?= (1,2)-        , 1 <|(,)|> 2 <|(,)|> 3   ~?= ((1,2),3)-        , 1 <|(,)|> (2 <|(,)|> 3) ~?= (1,(2,3))-        ]-    ]--tLevel1 = ("Level1" ~:) |$> [-      (+) |$> [1] |*> [2]      ~?= [3]--    , TestList $ ("|$>" ~:) |$> [ -          (1+) |$> [2] ~?= [3]-        , (1:) |$> [[]] ~?= [[1]]-        , ("a"++) |$> ["b"] ~?= ["ab"]-        , (True &&) |$> [False] ~?= [False]-        , (True ||) |$> [False] ~?= [True]-    -        , (1+) |$> [0,1,2] ~?= [1,2,3]-        , (1+) |$> Just 0  ~?= Just 1-        , (1+) |$> Nothing ~?= Nothing-        , (1+) |$> Right 1  ~?= (Right 2 :: Either () Int)-        , (1+) |$> Left ()  ~?= (Left () :: Either () Int)-        ]-    , TestList $ ("|*>" ~:) |$> [ -          [(1+)] |*> [0,1,2] ~?= [1,2,3]-        , Just (1+) |*> Just 0  ~?= Just 1-        , Just (1+) |*> Nothing ~?= Nothing-        , Right (1+) |*> Right 1 ~?= (Right 2 :: Either () Int)-        , Right (1+) |*> Left () ~?= (Left () :: Either () Int)--        ]-    , TestList $ ("<$|" ~:) |$> [ -          [1] <$| (+2)  ~?= [3]--        , ("("++)|$> ["a","b"] <$|(++")") ~?= ["(a)", "(b)"]-        ]-    , TestList $ ("<$| and |*>" ~:) |$> [ -          [1] <$|(+)|*> [0,1,2] ~?= [1,2,3]-        , Just 1 <$|(+)|*> Just 0  ~?= Just 1-        , Just 1 <$|(+)|*> Nothing ~?= Nothing-        , Right 1 <$|(+)|*> Right 1 ~?= (Right 2 :: Either () Int)-        , Right 1 <$|(+)|*> Left () ~?= (Left () :: Either () Int)--        , [1,11] <$|(+)|*> [0,1,2]              ~?= [1,2,3,11,12,13]-        , [0,1] <$|(+)|*> [2,3] <$|(^)|*> [4,5] ~?= [16,32,81,243,81,243,256,1024]--        , getZipList (ZipList ['a'..'e'] <$|(,)|*> ZipList [1..]) ~?= [('a',1),('b',2),('c',3),('d',4),('e',5)]--        ]-    , TestList $ ("<$|, |*> and higher-order-function" ~:) |$> [ -          foldr (\n acc -> n <$|(+)|*> acc) ((*:) 0) [Just 1, Just 2,  Just 3] ~?= Just 6-        , foldr (\n acc -> n <$|(+)|*> acc) ((*:) 0) [Just 1, Nothing, Just 3] ~?= Nothing--        , foldr (\x acc -> x <$|(:)|*> acc) ((*:) []) [Just 1, Just 2,  Just 3] ~?= Just [1,2,3]-        , foldr (\x acc -> x <$|(:)|*> acc) ((*:) []) [Just 1, Nothing, Just 3] ~?= Nothing--        , filter ((10 >) <$|(&&)|*> even)                  [1..100] ~?= [2,4,6,8]-        , filter ((10 >) <$|(&&)|*> even <$|(&&)|*> (5 <)) [1..100] ~?= [6,8]-        ]-    , TestList $ ("|*, *|" ~:) |$> [ -          [1] <$|(+)|*  2           ~?= [3]-        , 1    *|(+)|$> [2]         ~?= [3]--        , [(1+)] |* 2               ~?= [3]-        , 1 *| [(+2)]               ~?= [3]-        , 1 *| [(+)] |* 2           ~?= [3]--       , [1] <$|(+)|* 2 <$|(-)|* 3 ~?= [0]-       , 1 *|(+)|$> [2] <$|(-)|* 3 ~?= [0]--        , Just 1 <$|(,)|* 2  ~?= Just (1,2)-        , 1 *|Just (,)|* 2 ~?= Just (1,2)-        -        , 1 *|[(+),(-),(*),(^)]|* 2     ~?= [3,-1,2,1]-        ]--   , TestList $ ("other" ~:) |$> [ -          [1] <$|(+)|> 2      ~?= [3]-        --, [2] <*| [1] <$| (+) ~?= [3]  -- invalid form-        , [2] <*|(+)|$> [1]   ~?= [3]-        ]-     ]--tLevel2 = ("Level2" ~:) |$> [-      (+) |$>> [Just 1] |*>> [Just 2]      ~?= [Just 3]--    , TestList $ ("<<$| and |*>>" ~:) |$> [ -          [Just 1] <<$|(+)|*>> [Just 2]              ~?= [Just 3]-        , [[1]] <<$|(+)|*>> [[2]] <<$|(-)|*>> [[3]]  ~?= [[0]]--        , [Just 1] <<$|(,)|*>> [Just 2]              ~?= [Just (1,2)]-        ]-    , TestList $ ("<<$|, |*>> and higher-order-function" ~:) |$> [ -          foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ((Right . Just) |$> [1,2,3])               ~?= (Right (Just 6) :: Either () (Maybe Int))-        , foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) (Right |$> [Just 1,Nothing,Just 3])        ~?= (Right Nothing :: Either () (Maybe Int))-        , foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ([Right (Just 1), Right Nothing, Left ()]) ~?= (Left () :: Either () (Maybe Int))-        ]-    , TestList $ ("|**, |*-, |-*, **|, *-|, -*|" ~:) |$> [ -          [Just 1] <<$|(+)|** 2          ~?= [Just 3]-        , [Just 1] <<$|(+)|*- Just 2     ~?= [Just 3]-        , [Just 1] <<$|(+)|-* [2]        ~?= [Just 3]-        , 1      **|(+)|$>> [Just 2]     ~?= [Just 3]-        , Just 1 *-|(+)|$>> [Just 2]     ~?= [Just 3]-        , [1]    -*|(+)|$>> [Just 2]     ~?= [Just 3]-        , 1 **|[Just (+)]|** 2        ~?= [Just 3]-        , 1 **|[Just (+), Just (-), Just (*), Nothing]|** 2 ~?= [Just 3,Just (-1),Just 2,Nothing]-        , [0,1] -*|[Just (+), Just (-), Just (*), Nothing]|*- Just 2 ~?= [Just 2,Just 3,Just (-2),Just (-1),Just 0,Just 2,Nothing,Nothing]--        , [[1]] <<$|(+)|** 2 <<$|(-)|** 3    ~?= [[0]]-        , 1 **|(+)|$>> [[2]] <<$|(-)|** 3    ~?= [[0]]-        ]--{--    , TestList $ ("*>>, <<*, -*>, <-*, *->, <*-" ~:) |$> [ --        ]--}-    ]--tLevel3 = ("Level3" ~:) |$> [-      (+) |$>>> Right [Just 1] |*>>> Right [Just 2]      ~?= (Right [Just 3] :: Either () [Maybe Int])--    , TestList $ ("<<<$| and |*>>>" ~:) |$> [ -          Right [Just 1] <<<$|(+)|*>>> Right [Just 2]         ~?= (Right [Just 3] :: Either () [Maybe Int])-        , [[[1]]] <<<$|(+)|*>>> [[[2]]] <<<$|(-)|*>>> [[[3]]] ~?= [[[0]]]--        , Right [Just 1] <<<$|(,)|*>>> Right [Just 2]       ~?= (Right [Just (1,2)] :: Either () [Maybe (Int,Int)])-        ]-    ]--

@@ -1,30 +0,0 @@-import Test.HUnit--import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.Commutative--main :: IO ()-main = do-    runTestTT $ TestList [-          TestList tTest0-        ]-    runTestTT tests_0-    return ()--------------------------------------------------------------------- unit test-------------------------------------------------------------------tTest0 = ("tTest0" ~:) |$> [-       commute (Just [1]) ~?= [Just 1]-     ]--tests_0 :: Test-tests_0 = test [ -      "IO" ~: do-        actual <- commute ((-*) [1..3])-        actual @?= [1,2,3]-    ]--

@@ -1,147 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-import Test.HUnit--import DeepControl.Applicative ((|$>))-import DeepControl.Monad ((>-))--import Control.Monad.Except-import Control.Monad.RWS-import qualified Data.Map as M----------------------------------------------------- Data-types--type Name = String          -- variable names---- Expression-data Exp = Lit Int          -- Literal-         | Var Name         -- Variable-         | Plus Exp Exp     -- (+)-         | Lam Name Exp     -- λ-         | App Exp Exp      -- Application-         deriving (Show, Eq)---- Value-data Value = IntVal Int          -- Int Value -           | FunVal Env Name Exp -- Functional Value-           deriving (Show, Eq)---- Environment-type Env = M.Map Name Value    -- mapping from names to values----------------------------------------------------- Monad-Transform--type EvalError = String--newtype Eval a = Eval (RWST Env [String] Int -                      (ExceptT EvalError-                          IO) a)-  deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader Env, MonadWriter [String], MonadState Int)--unEval :: Eval a -> (RWST Env [String] Int -                    (ExceptT EvalError-                        IO) a)-unEval (Eval a) = a--runEval :: Eval a -           -> Env  -- Reader-           -> Int  -- States-           -> IO (Either EvalError (a, Int, [String])) -runEval (Eval x) env state = x >- \x -> runRWST x env state-                               >- runExceptT---- ------------------------------------------------- Interpreter--tick :: (Num s, MonadState s m) => m ()-tick = do -    st <- get-    put (st + 1)--eval :: Exp -> Eval Value-eval (Lit i)   = do -    tick-    liftIO $ print i-    return $ IntVal i-eval (Var n)   = do -    tick-    tell [n]-    env <- ask-    case M.lookup n env of-        Nothing  -> throwError $ "unbound variable: " ++ n-        Just val -> return val-eval (Plus e1 e2) = do -    tick-    e1' <- eval e1-    e2' <- eval e2-    case (e1', e2') of-        (IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)-        _                      -> throwError "type error in addition"-eval (Lam n e) = do -    tick-    env <- ask-    return $ FunVal env n e-eval (App e1 e2) = do -    tick-    val1 <- eval e1-    val2 <- eval e2-    case val1 of-        FunVal env' n body -> local (const (M.insert n val2 env')) $ eval body-        _                  -> throwError "type error in application"----------------------------------------------------- Examples---- 12 + ((\x -> x) (4 + 2))-exp1 :: Exp-exp1 = Lit 12 `Plus` ((Lam "x" (Var "x")) `App` (Lit 4 `Plus` Lit 2))---- (\x -> (\y -> x + y)) a b-exp2 :: Exp-exp2 = (Lam "x" (Lam "y" ((Var "x") `Plus` (Var "y")))) `App` (Var "a") `App` (Var "b")---- An environment-env :: Env-env = M.fromList [ ("a", IntVal 1)-                 , ("b", IntVal 2)-                 , ("c", IntVal 3)  -                 , ("d", IntVal 4)-                 ] ----------------------------------------------------- Tests---- > runEval (eval exp1) env 0--- 12--- 4--- 2--- Right (IntVal 18,8,["x"])---- > runEval (eval exp2) env 0--- Right (IntVal 3,9,["a","b","x","y"])---- > runEval (eval $ Var "x") env 0--- Left "unbound variable: x"--------------------------------------------------------------------- unit test-------------------------------------------------------------------main :: IO ()-main = do-    runTestTT tests_-    return ()--tests_ :: Test-tests_ = test [ -      "IO" ~: do-        actual <- runEval (eval exp1) env 0-        actual @?= Right (IntVal 18,8,["x"])--        actual <- runEval (eval exp2) env 0-        actual @?= Right (IntVal 3,9,["a","b","x","y"])-    ]---

@@ -1,51 +0,0 @@-import Test.HUnit--import DeepControl.Applicative-import DeepControl.Commutative (commute)-import DeepControl.Monad ((>-))-import DeepControl.Monad.Trans (trans2)-import DeepControl.Monad.Trans.Reader--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)- -ackermannR :: Int -> Int -              -> ReaderT2 TimeLimit IO Maybe Int    -- ReaderT2-IO-Maybe Monad-ackermannR x y = do-    timelimit <- ask-    trans2 $ ackermannTimeLimit timelimit x y       -- transform IO-Maybe function to ReaderT2-IO-Maybe function--calc_ackermann :: TimeLimit -> Int -> Int -> IO (Maybe Int)-calc_ackermann timelimit x y = ackermannR 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-    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]-    ]---

@@ -1,345 +0,0 @@-import Test.HUnit hiding (State)--import DeepControl.Applicative ((*:))-import DeepControl.Monad ((>-))-import DeepControl.Commutative (cmap)-import DeepControl.Monad.Trans (liftIO, trans, trans2)-import DeepControl.Monad.Trans.State--import Control.Monad.Trans.Maybe---------------------------------------------------- State--push :: a -> State [a] a-push x = do -    xs <- get-    put (x:xs)-    return x--pop :: State [a] a-pop = do -    xs <- get-    put (tail xs)-    return (head xs)---- > runState (push 1 >> push 2 >> push 3) []--- (3,[3,2,1])--- > runState (push 1 >> push 2 >> push 3 >> pop >> pop) []--- (2,[1])--poland :: String -> State [Double] Double-poland "+" = do -    x <- pop-    y <- pop-    push (y + x)-poland "-" = do -    x <- pop-    y <- pop-    push (y - x)-poland "*" = do -    x <- pop-    y <- pop-    push (y * x)-poland "/" = do-    x <- pop-    y <- pop-    push (y / x)-poland x = push (read x :: Double)--poland_calc :: [String] -> (Double, [Double])-poland_calc xs = (cmap poland xs >> pop) >- \x -> runState x []---- > poland_calc ["1","2","*"]--- (2.0, [])--- > poland_calc ["1","2","-"]--- (-1.0, [])--- > poland_calc ["1","2","+","3","*"]--- (9.0, [])--- > poland_calc ["1","2","+","3","*","3","/"]--- (3.0, [])--- > poland_calc ["1","2","+","3","*","0","/"]--- (Infinity, [])---------------------------------------------------- StateT-Maybe--pushS :: a -> StateT [a] Maybe a-pushS x = do -    xs <- get-    put (x:xs)-    return x--popS :: StateT [a] Maybe a-popS = do -    xs <- get-    put (tail xs)-    return (head xs)---- > runStateT (pushT 1 >> pushT 2 >> pushT 3) []--- Just (3,[3,2,1])--- > runStateT (pushT 1 >> pushT 2 >> pushT 3 >> popT >> popT) []--- Just (2,[1])--polandS :: String -> StateT [Double] Maybe Double-polandS "+" = do -    x <- popS-    y <- popS-    pushS (y + x)-polandS "-" = do -    x <- popS-    y <- popS-    pushS (y - x)-polandS "*" = do -    x <- popS-    y <- popS-    pushS (y * x)-polandS "/" = do-    x <- popS-    y <- popS-    trans $ guard (x /= 0)-    pushS (y / x)-polandS x = pushS (read x :: Double)--poland_calcS :: [String] -> Maybe (Double, [Double])-poland_calcS xs = (cmap polandS xs >> popS) >- \x -> runStateT x []---- > poland_calcS ["1","2","*"]--- Just (2.0, [])--- > poland_calcS ["1","2","-"]--- Just (-1.0, [])--- > poland_calcS ["1","2","+","3","*"]--- Just (9.0, [])--- > poland_calcS ["1","2","+","3","*","3","/"]--- Just (3.0, [])--- > poland_calcS ["1","2","+","3","*","0","/"]--- Nothing---------------------------------------------------- MaybeT-StateT-IO Monad--pushMS :: a -> MaybeT (StateT [a] IO) a-pushMS x = do -    xs <- get-    put (x:xs)-    return x-popMS :: MaybeT (StateT [a] IO) a-popMS = do -    xs <- get-    put (tail xs)-    return (head xs)--polandMS :: String -> MaybeT (StateT [Double] IO) Double-polandMS "+" = do -    x <- popMS-    y <- popMS-    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))-    pushMS (y + x)-polandMS "-" = do -    x <- popMS-    y <- popMS-    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))-    pushMS (y - x)-polandMS "*" = do-    x <- popMS-    y <- popMS-    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))-    pushMS (y * x)-polandMS "/" = do-    x <- popMS-    y <- popMS-    liftIO $ putStr (show y ++" / "++ show x ++" = ")-    guard (x /= 0)-    liftIO $ putStr (show (y / x) ++"\n")-    pushMS (y / x)-polandMS x = pushMS (read x :: Double)--poland_calcMS :: [String] -> IO (Maybe Double, [Double])-poland_calcMS xs = (cmap polandMS xs >> popMS) >- runMaybeT-                                               >- \x -> runStateT x []---- > poland_calcS2 ["1","2","*"]--- 1.0 * 2.0 = 2.0--- (Just 2.0, [])---------------------------------------------------- StateT-MaybeT-IO Monad--pushSM :: a -> StateT [a] (MaybeT IO) a-pushSM x = do -    xs <- get-    put (x:xs)-    return x-popSM :: StateT [a] (MaybeT IO) a-popSM = do -    xs <- get-    put (tail xs)-    return (head xs)--polandSM :: String -> StateT [Double] (MaybeT IO) Double-polandSM "+" = do -    x <- popSM-    y <- popSM-    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))-    pushSM (y + x)-polandSM "-" = do -    x <- popSM-    y <- popSM-    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))-    pushSM (y - x)-polandSM "*" = do-    x <- popSM-    y <- popSM-    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))-    pushSM (y * x)-polandSM "/" = do-    x <- popSM-    y <- popSM-    liftIO $ putStr (show y ++" / "++ show x ++" = ")-    guard (x /= 0)-    liftIO $ putStr (show (y / x) ++"\n")-    pushSM (y / x)-polandSM x = pushSM (read x :: Double)--poland_calcSM :: [String] -> IO (Maybe (Double, [Double]))-poland_calcSM xs = (cmap polandSM xs >> popSM) >- \x -> runStateT x []-                                               >- runMaybeT---------------------------------------------------- StateT2-IO-Maybe--pushS2 :: a -> StateT2 [a] IO Maybe a-pushS2 x = do -    xs <- get-    put (x:xs)-    return x-popS2 :: StateT2 [a] IO Maybe a-popS2 = do -    xs <- get-    put (tail xs)-    return (head xs)--polandS2 :: String -> StateT2 [Double] IO Maybe Double-polandS2 "+" = do -    x <- popS2-    y <- popS2-    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))-    pushS2 (y + x)-polandS2 "-" = do -    x <- popS2-    y <- popS2-    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))-    pushS2 (y - x)-polandS2 "*" = do-    x <- popS2-    y <- popS2-    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))-    pushS2 (y * x)-polandS2 "/" = do-    x <- popS2-    y <- popS2-    liftIO $ putStr (show y ++" / "++ show x ++" = ")-    trans2 $ (*:) $ guard (x /= 0)-    liftIO $ putStr (show (y / x) ++"\n")-    pushS2 (y / x)-polandS2 x = pushS2 (read x :: Double)--poland_calcS2 :: [String] -> IO (Maybe (Double, [Double]))-poland_calcS2 xs = (cmap polandS2 xs >> popS2) >- \x -> runStateT2 x []---- > 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--------------------------------------------------------------------- unit test-------------------------------------------------------------------main :: IO ()-main = do-    runTestTT tests_Level0-    print "---------------------"-    runTestTT tests_Level1-    print "---------------------"-    runTestTT tests_Level1_2-    print "---------------------"-    runTestTT tests_Level1_3-    print "---------------------"-    runTestTT tests_Level2-    return ()--tests_Level0 :: Test-tests_Level0 = test [ -      "poland" ~: do-        let actual = poland_calc ["1","2","*"]-        actual @?= (2.0, [])--        let actual = poland_calc ["1","2","+","3","*","3","/"]-        actual @?= (3.0, [])--        --actual <- poland_calc ["1","2","+","3","*","0","/"]-        --actual @?= Infinity-    ]--tests_Level1 :: Test-tests_Level1 = test [ -      "polandT" ~: do-        let actual = poland_calcS ["1","2","*"]-        actual @?= Just (2.0, [])--        let actual = poland_calcS ["1","2","+","3","*","3","/"]-        actual @?= Just (3.0, [])--        let actual = poland_calcS ["1","2","+","3","*","0","/"]-        actual @?= Nothing-    ]--tests_Level1_2 :: Test-tests_Level1_2 = test [ -      "polandMS" ~: do-        actual <- poland_calcMS ["1","2","*"]-        actual @?= (Just 2.0, [])--        actual <- poland_calcMS ["1","2","+","3","*","3","/"]-        actual @?= (Just 3.0, [])--        actual <- poland_calcMS ["1","2","+","3","*","0","/"]-        actual @?= (Nothing, [])-    ]--tests_Level1_3 :: Test-tests_Level1_3 = test [ -      "polandSM" ~: do-        actual <- poland_calcSM ["1","2","*"]-        actual @?= Just (2.0, [])--        actual <- poland_calcSM ["1","2","+","3","*","3","/"]-        actual @?= Just (3.0, [])--        actual <- poland_calcSM ["1","2","+","3","*","0","/"]-        actual @?= Nothing-    ]--tests_Level2 :: Test-tests_Level2 = test [ -      "polandT2" ~: do-        actual <- poland_calcS2 ["1","2","*"]-        actual @?= Just (2.0, [])--        actual <- poland_calcS2 ["1","2","+","3","*","0","/"]-        actual @?= Nothing-    ]-

@@ -1,142 +0,0 @@-import Test.HUnit--import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.Monad.Trans.Writer-import DeepControl.Monad.Trans.Reader--import Control.Monad.Identity--import Safe--main :: IO ()-main = do-    runTestTT $ TestList [-          TestList tLevel0-        , TestList tLevel2-        , TestList tLevel3-        ]-    runTestTT tests_Level0-    runTestTT tests_Level2-    runTestTT tests_Level3-    return ()--tLevel0 = ("Level0" ~:) |$>-    [ (3 >- Just)    ~?= Just 3-    , (Just -< 3)    ~?= Just 3--    , (1 >- (+1) >- (*2) >- (+3))     ~?= 7-    , (1 >- ((+1) >-> (*2) >-> (+3))) ~?= 7-    , (((3+) <-< (2*) <-< (1+)) -< 1) ~?= 7---- invalid forms--- ((3+) -< (2*) -< (1+) -< 1)-    ]--tLevel2 = ("Level2" ~:) |$> [-      ([[1]] >>== \x -> [[x]]) ~?= [[1]]-    , ([[1]] >>== \x -> (**:) x) ~?= [[1]]-    , (Just [1] >>== \x -> (**:) x) ~?= Just [1]-    , ([Just 1] >>== \x -> (**:) x) ~?= [Just 1]-    , (Right [1] >>== \x -> (**:) x) ~?= (Right [1] :: Either () [Int])--    , (Right [0] >>== \x -> (**:) (x+1) >>== \x -> (**:) (x+2)) ~?= (Right [3] :: Either () [Int])-    ]--tLevel3 = ("Level3" ~:) |$> [-      ([[[1]]] >>>== \x -> (***:) x) ~?= [[[1]]]-    , ((Just [[1]]) >>>== \x -> (***:) x) ~?= Just [[1]]-    , (([Just [1]]) >>>== \x -> (***:) x) ~?= [Just [1]]-    , (Right (Just [1]) >>>== \x -> (***:) x) ~?= (Right (Just [1]) :: Either () (Maybe [Int]))--    , (Right (Just [0]) >>>== \x -> (***:) (x+1) >>>== \x -> (***:) (x+2)) ~?= (Right (Just [3]) :: Either () (Maybe [Int]))-    , (Right Nothing    >>>== \x -> (***:) (x+1) >>>== \x -> (***:) (x+2)) ~?= (Right Nothing :: Either () (Maybe [Int]))-    ]--tests_Level0 :: Test-tests_Level0 = test [ -      "plus" ~: "(>-)" ~: do-        let plus :: Int -> Int -> Int-            plus x y = -                x >- \a ->-                y >- \b ->-                a + b-        plus 3 4 @?= 7-    ]--tests_Level2 :: Test-tests_Level2 = test [ -      "List-List" ~: "(>>==)" ~: do-        let actual :: [[String]]-            actual = [["a","b"]] >>== \x ->-                     [[0],[1,2]] >>== \y ->-                     (**:) $ x ++ show y-        actual @?= [["a0","b0"],["a0","b1","b2"],["a1","a2","b0"],["a1","a2","b1","b2"]]--    , "List-Maybe" ~: "(>>==), (>>~)" ~: do-        let actual :: [Maybe Double]-            actual = (readMay |$> ["1", "2", "_"]) >>== \a ->-                     (readMay |$> ["0", "2"]) >>== \b ->-                     ((*:) $ guard (b /= 0.0)) >>~-                     (**:) $ a / b-        actual @?= [Just 0.5,Just 1.0,Nothing]-    , "List-Maybe" ~: "(->~)" ~: do-        let actual :: [Maybe Double]-            actual = (readMay |$> ["1", "2", "_"]) >>== \a ->-                     (readMay |$> ["0", "2"]) >>== \b ->-                     guard (b /= 0.0) ->~-                     (**:) $ a / b-        actual @?= [Just 0.5,Just 1.0,Nothing]--    , "(->)-Maybe" ~: "(>-==)" ~: do-        let lengthM :: [Int] -> Maybe Int-            lengthM [] = Nothing-            lengthM xs = Just (length xs) -            averageM :: [Int] -> Maybe Double-            averageM = -                sum >-== \s ->-                lengthM >>== \l ->-                (**:) $ fromIntegral s / fromIntegral l-        averageM [10, 25, 70] @?= Just 35.0-        averageM []           @?= Nothing-    , "Reader-Maybe" ~: do-        let sumR :: Reader [Int] Int-            sumR = sum |$> ask-            lengthRM :: Reader [Int] (Maybe Int)-            lengthRM = ReaderT $ \r -> Identity $ case r of-                                        [] -> Nothing-                                        xs -> Just (length xs) -            averageRM :: Reader [Int] (Maybe Double)-            averageRM = -                sumR >-== \s ->-                lengthRM >>== \l ->-                (**:) $ fromIntegral s / fromIntegral l-        runReader averageRM [10, 25, 70] @?= Just 35.0-        runReader averageRM []           @?= Nothing--    , "Maybe-Writer" ~: "(-*)" ~: do-        let factorial :: Int -> Maybe (Writer [Int] Int)-            factorial n | n < 0  = (-*) Nothing-            factorial n | n == 0 = (*:) $ tell [0] >> return 1-            factorial n | n > 0  = -                factorial (n-1) >>== \v ->-                tell [v] ->~-                (**:) (n * v)-        (runWriter |$> factorial 5) @?= Just (120,[0,1,1,2,6,24])--    ]--tests_Level3 :: Test-tests_Level3 = test [ -      "IO-Maybe-Writer" ~: "(>>>==), (-->~), (*-*)" ~: do-        let factorial :: Int -> IO (Maybe (Writer [Int] Int))-            factorial n | n < 0  = (*-*) Nothing-            factorial n | n == 0 = (**:) $ tell [0] >> return 1-            factorial n | n > 0  = -                factorial (n-1) >>>== \v ->-                tell [v] -->~-                (***:) (n * v)-        actual <- factorial 5-        (runWriter |$> actual) @?= Just (120,[0,1,1,2,6,24])-    ]-

@@ -1,60 +0,0 @@-import Test.HUnit hiding (State)--import DeepControl.Monad.Morph-import DeepControl.Monad.Trans.State-import DeepControl.Monad.Trans.Writer--tick :: State Int ()-tick = modify (+1)--tock                        ::                   StateT Int IO ()-tock = do-    generalize |>| tick     :: (Monad      m) => StateT Int m  ()-    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()---- λ> runStateT tock 0--- Tock!--- ((),1)---- i.e. :: StateT Int (WriterT [Int] Identity) ()-save    :: StateT Int (Writer  [Int]) ()-save = do-    n <- get-    lift $ tell [n]--program ::                   StateT Int (WriterT [Int] IO) ()-program = replicateM_ 4 $ do-    lift |>| tock-        :: (MonadTrans t) => StateT Int (t             IO) ()-    generalize |>>| save-        :: (Monad      m) => StateT Int (WriterT [Int] m ) ()---- λ> execWriterT (runStateT program 0)--- Tock!--- Tock!--- Tock!--- Tock!--- [1,2,3,4]--------------------------------------------------------------------- unit test-------------------------------------------------------------------main :: IO ()-main = do-    runTestTT tests_-    return ()--tests_ :: Test-tests_ = test [ -      "tock" ~: do-        actual <- runStateT tock 0-        actual @?= ((),1)--    , "program" ~: do-        actual <- execWriterT (runStateT program 0)-        actual @?= [1,2,3,4]-    ]---

@@ -1,22 +0,0 @@-import Test.HUnit--import DeepControl.Applicative-import DeepControl.Monad.Morph--import Control.Monad.List--main :: IO ()-main = do-    runTestTT $ TestList [-          TestList tLevel0-        ]-    return ()--f :: Maybe a -> [a]-f (Just x) = [x]-f Nothing = []--tLevel0 = ("Level0" ~:) |$>-    [ (f |>| ListT (Just [1,2,3]))    ~?= ListT [[1,2,3]]-    ]-

@@ -5,6 +5,9 @@  main :: IO () main = doctest [ "DeepControl/Applicative.hs"+               , "DeepControl/Commutative.hs"                , "DeepControl/Monad.hs"+               , "DeepControl/Monad/Trans.hs"+               , "DeepControl/Monad/Morph.hs"                , "DeepControl/Arrow.hs"                ]

@@ -0,0 +1,181 @@+import Test.HUnit++import DeepControl.Applicative++main :: IO ()+main = run >> return ()++-- | Run Unit-Test of this module. +run = runTestTT $ TestList +        [ TestList tLevel0+        , TestList tLevel1+        , TestList tLevel2+        , TestList tLevel3++        ]++----------------------------------------------------------------+-- unit test+----------------------------------------------------------------++tLevel0 = ("Level0" ~:) |$> [ +      TestList $ ("|>" ~:) |$> [ +          (1+) |> 2  ~?= 3+        , (1:) |> [] ~?= [1]+        , ("a"++) |> "b" ~?= "ab"+        , (True &&) |> False ~?= False+        , (True ||) |> False ~?= True+        ]++    , TestList $ ("<|" ~:) |$> [ +          1 <| (+2)  ~?= 3+        , 1 <| (:[]) ~?= [1]+        , "a" <| (++"b")  ~?= "ab"+        , True <| (&& False) ~?= False+        , True <| (|| False) ~?= True+        ]++    , TestList $ ("<| and |>" ~:) |$> [ +          1 <|(+)|> 2               ~?= 3+        , 1 <|(+)|> 2 <|(-)|> 3     ~?= 0+        , 1 <|(+)|> 2 <|(*)|> 3     ~?= 9++        , 1 <|(:)|> []             ~?= [1]+        , 1 <|(:)|> (2 <|(:)|> []) ~?= [1,2]++        , "a" <|(++)|> "b"              ~?= "ab"+        , "a" <|(++)|> "b" <|(++)|> "c" ~?= "abc"++        , True <|(&&)|> False ~?= False+        , True <|(||)|> False ~?= True++        , 1 <|(,)|> 2             ~?= (1,2)+        , 1 <|(,)|> 2 <|(,)|> 3   ~?= ((1,2),3)+        , 1 <|(,)|> (2 <|(,)|> 3) ~?= (1,(2,3))+        ]+    ]++tLevel1 = ("Level1" ~:) |$> [+      (+) |$> [1] |*> [2]      ~?= [3]++    , TestList $ ("|$>" ~:) |$> [ +          (1+) |$> [2] ~?= [3]+        , (1:) |$> [[]] ~?= [[1]]+        , ("a"++) |$> ["b"] ~?= ["ab"]+        , (True &&) |$> [False] ~?= [False]+        , (True ||) |$> [False] ~?= [True]+    +        , (1+) |$> [0,1,2] ~?= [1,2,3]+        , (1+) |$> Just 0  ~?= Just 1+        , (1+) |$> Nothing ~?= Nothing+        , (1+) |$> Right 1  ~?= (Right 2 :: Either () Int)+        , (1+) |$> Left ()  ~?= (Left () :: Either () Int)+        ]+    , TestList $ ("|*>" ~:) |$> [ +          [(1+)] |*> [0,1,2] ~?= [1,2,3]+        , Just (1+) |*> Just 0  ~?= Just 1+        , Just (1+) |*> Nothing ~?= Nothing+        , Right (1+) |*> Right 1 ~?= (Right 2 :: Either () Int)+        , Right (1+) |*> Left () ~?= (Left () :: Either () Int)++        ]+    , TestList $ ("<$|" ~:) |$> [ +          [1] <$| (+2)  ~?= [3]++        , ("("++)|$> ["a","b"] <$|(++")") ~?= ["(a)", "(b)"]+        ]+    , TestList $ ("<$| and |*>" ~:) |$> [ +          [1] <$|(+)|*> [0,1,2] ~?= [1,2,3]+        , Just 1 <$|(+)|*> Just 0  ~?= Just 1+        , Just 1 <$|(+)|*> Nothing ~?= Nothing+        , Right 1 <$|(+)|*> Right 1 ~?= (Right 2 :: Either () Int)+        , Right 1 <$|(+)|*> Left () ~?= (Left () :: Either () Int)++        , [1,11] <$|(+)|*> [0,1,2]              ~?= [1,2,3,11,12,13]+        , [0,1] <$|(+)|*> [2,3] <$|(^)|*> [4,5] ~?= [16,32,81,243,81,243,256,1024]++        , getZipList (ZipList ['a'..'e'] <$|(,)|*> ZipList [1..]) ~?= [('a',1),('b',2),('c',3),('d',4),('e',5)]++        ]+    , TestList $ ("<$|, |*> and higher-order-function" ~:) |$> [ +          foldr (\n acc -> n <$|(+)|*> acc) ((*:) 0) [Just 1, Just 2,  Just 3] ~?= Just 6+        , foldr (\n acc -> n <$|(+)|*> acc) ((*:) 0) [Just 1, Nothing, Just 3] ~?= Nothing++        , foldr (\x acc -> x <$|(:)|*> acc) ((*:) []) [Just 1, Just 2,  Just 3] ~?= Just [1,2,3]+        , foldr (\x acc -> x <$|(:)|*> acc) ((*:) []) [Just 1, Nothing, Just 3] ~?= Nothing++        , filter ((10 >) <$|(&&)|*> even)                  [1..100] ~?= [2,4,6,8]+        , filter ((10 >) <$|(&&)|*> even <$|(&&)|*> (5 <)) [1..100] ~?= [6,8]+        ]+    , TestList $ ("|*, *|" ~:) |$> [ +          [1] <$|(+)|*  2           ~?= [3]+        , 1    *|(+)|$> [2]         ~?= [3]++        , [(1+)] |* 2               ~?= [3]+        , 1 *| [(+2)]               ~?= [3]+        , 1 *| [(+)] |* 2           ~?= [3]++       , [1] <$|(+)|* 2 <$|(-)|* 3 ~?= [0]+       , 1 *|(+)|$> [2] <$|(-)|* 3 ~?= [0]++        , Just 1 <$|(,)|* 2  ~?= Just (1,2)+        , 1 *|Just (,)|* 2 ~?= Just (1,2)+        +        , 1 *|[(+),(-),(*),(^)]|* 2     ~?= [3,-1,2,1]+        ]++   , TestList $ ("other" ~:) |$> [ +          [1] <$|(+)|> 2      ~?= [3]+        --, [2] <*| [1] <$| (+) ~?= [3]  -- invalid form+        , [2] <*|(+)|$> [1]   ~?= [3]+        ]+     ]++tLevel2 = ("Level2" ~:) |$> [+      (+) |$>> [Just 1] |*>> [Just 2]      ~?= [Just 3]++    , TestList $ ("<<$| and |*>>" ~:) |$> [ +          [Just 1] <<$|(+)|*>> [Just 2]              ~?= [Just 3]+        , [[1]] <<$|(+)|*>> [[2]] <<$|(-)|*>> [[3]]  ~?= [[0]]++        , [Just 1] <<$|(,)|*>> [Just 2]              ~?= [Just (1,2)]+        ]+    , TestList $ ("<<$|, |*>> and higher-order-function" ~:) |$> [ +          foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ((Right . Just) |$> [1,2,3])               ~?= (Right (Just 6) :: Either () (Maybe Int))+        , foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) (Right |$> [Just 1,Nothing,Just 3])        ~?= (Right Nothing :: Either () (Maybe Int))+        , foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ([Right (Just 1), Right Nothing, Left ()]) ~?= (Left () :: Either () (Maybe Int))+        ]+    , TestList $ ("|**, |*-, |-*, **|, *-|, -*|" ~:) |$> [ +          [Just 1] <<$|(+)|** 2          ~?= [Just 3]+        , [Just 1] <<$|(+)|*- Just 2     ~?= [Just 3]+        , [Just 1] <<$|(+)|-* [2]        ~?= [Just 3]+        , 1      **|(+)|$>> [Just 2]     ~?= [Just 3]+        , Just 1 *-|(+)|$>> [Just 2]     ~?= [Just 3]+        , [1]    -*|(+)|$>> [Just 2]     ~?= [Just 3]+        , 1 **|[Just (+)]|** 2        ~?= [Just 3]+        , 1 **|[Just (+), Just (-), Just (*), Nothing]|** 2 ~?= [Just 3,Just (-1),Just 2,Nothing]+        , [0,1] -*|[Just (+), Just (-), Just (*), Nothing]|*- Just 2 ~?= [Just 2,Just 3,Just (-2),Just (-1),Just 0,Just 2,Nothing,Nothing]++        , [[1]] <<$|(+)|** 2 <<$|(-)|** 3    ~?= [[0]]+        , 1 **|(+)|$>> [[2]] <<$|(-)|** 3    ~?= [[0]]+        ]++{-+    , TestList $ ("*>>, <<*, -*>, <-*, *->, <*-" ~:) |$> [ ++        ]+-}+    ]++tLevel3 = ("Level3" ~:) |$> [+      (+) |$>>> Right [Just 1] |*>>> Right [Just 2]      ~?= (Right [Just 3] :: Either () [Maybe Int])++    , TestList $ ("<<<$| and |*>>>" ~:) |$> [ +          Right [Just 1] <<<$|(+)|*>>> Right [Just 2]         ~?= (Right [Just 3] :: Either () [Maybe Int])+        , [[[1]]] <<<$|(+)|*>>> [[[2]]] <<<$|(-)|*>>> [[[3]]] ~?= [[[0]]]++        , Right [Just 1] <<<$|(,)|*>>> Right [Just 2]       ~?= (Right [Just (1,2)] :: Either () [Maybe (Int,Int)])+        ]+    ]++

@@ -0,0 +1,30 @@+import Test.HUnit++import DeepControl.Applicative+import DeepControl.Monad+import DeepControl.Commutative++main :: IO ()+main = do+    runTestTT $ TestList [+          TestList tTest0+        ]+    runTestTT tests_0+    return ()++----------------------------------------------------------------+-- unit test+----------------------------------------------------------------++tTest0 = ("tTest0" ~:) |$> [+       commute (Just [1]) ~?= [Just 1]+     ]++tests_0 :: Test+tests_0 = test [ +      "IO" ~: do+        actual <- commute ((-*) [1..3])+        actual @?= [1,2,3]+    ]++

@@ -0,0 +1,147 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+import Test.HUnit++import DeepControl.Applicative ((|$>))+import DeepControl.Monad ((>-))++import Control.Monad.Except+import Control.Monad.RWS+import qualified Data.Map as M++------------------------------------------------+-- Data-types++type Name = String          -- variable names++-- Expression+data Exp = Lit Int          -- Literal+         | Var Name         -- Variable+         | Plus Exp Exp     -- (+)+         | Lam Name Exp     -- λ+         | App Exp Exp      -- Application+         deriving (Show, Eq)++-- Value+data Value = IntVal Int          -- Int Value +           | FunVal Env Name Exp -- Functional Value+           deriving (Show, Eq)++-- Environment+type Env = M.Map Name Value    -- mapping from names to values++------------------------------------------------+-- Monad-Transform++type EvalError = String++newtype Eval a = Eval (RWST Env [String] Int +                      (ExceptT EvalError+                          IO) a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader Env, MonadWriter [String], MonadState Int)++unEval :: Eval a -> (RWST Env [String] Int +                    (ExceptT EvalError+                        IO) a)+unEval (Eval a) = a++runEval :: Eval a +           -> Env  -- Reader+           -> Int  -- States+           -> IO (Either EvalError (a, Int, [String])) +runEval (Eval x) env state = x >- \x -> runRWST x env state+                               >- runExceptT++-- ----------------------------------------------+-- Interpreter++tick :: (Num s, MonadState s m) => m ()+tick = do +    st <- get+    put (st + 1)++eval :: Exp -> Eval Value+eval (Lit i)   = do +    tick+    liftIO $ print i+    return $ IntVal i+eval (Var n)   = do +    tick+    tell [n]+    env <- ask+    case M.lookup n env of+        Nothing  -> throwError $ "unbound variable: " ++ n+        Just val -> return val+eval (Plus e1 e2) = do +    tick+    e1' <- eval e1+    e2' <- eval e2+    case (e1', e2') of+        (IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)+        _                      -> throwError "type error in addition"+eval (Lam n e) = do +    tick+    env <- ask+    return $ FunVal env n e+eval (App e1 e2) = do +    tick+    val1 <- eval e1+    val2 <- eval e2+    case val1 of+        FunVal env' n body -> local (const (M.insert n val2 env')) $ eval body+        _                  -> throwError "type error in application"++------------------------------------------------+-- Examples++-- 12 + ((\x -> x) (4 + 2))+exp1 :: Exp+exp1 = Lit 12 `Plus` ((Lam "x" (Var "x")) `App` (Lit 4 `Plus` Lit 2))++-- (\x -> (\y -> x + y)) a b+exp2 :: Exp+exp2 = (Lam "x" (Lam "y" ((Var "x") `Plus` (Var "y")))) `App` (Var "a") `App` (Var "b")++-- An environment+env :: Env+env = M.fromList [ ("a", IntVal 1)+                 , ("b", IntVal 2)+                 , ("c", IntVal 3)  +                 , ("d", IntVal 4)+                 ] ++------------------------------------------------+-- Tests++-- > runEval (eval exp1) env 0+-- 12+-- 4+-- 2+-- Right (IntVal 18,8,["x"])++-- > runEval (eval exp2) env 0+-- Right (IntVal 3,9,["a","b","x","y"])++-- > runEval (eval $ Var "x") env 0+-- Left "unbound variable: x"++----------------------------------------------------------------+-- unit test+----------------------------------------------------------------++main :: IO ()+main = do+    runTestTT tests_+    return ()++tests_ :: Test+tests_ = test [ +      "IO" ~: do+        actual <- runEval (eval exp1) env 0+        actual @?= Right (IntVal 18,8,["x"])++        actual <- runEval (eval exp2) env 0+        actual @?= Right (IntVal 3,9,["a","b","x","y"])+    ]+++

@@ -0,0 +1,87 @@+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]+    ]+

@@ -0,0 +1,458 @@+import Test.HUnit hiding (State)++import DeepControl.Applicative +import DeepControl.Monad ((>-))+import DeepControl.Commutative (cmap)+import DeepControl.Monad.Trans+import DeepControl.Monad.Trans.State+import DeepControl.Monad.Trans.Except++import Control.Monad.Trans.Maybe+import Control.Monad.Identity++-----------------------------------------------+-- State++push :: a -> State [a] a+push x = do +    xs <- get+    put (x:xs)+    return x++pop :: State [a] a+pop = do +    xs <- get+    put (tail xs)+    return (head xs)++-- > runState (push 1 >> push 2 >> push 3) []+-- (3,[3,2,1])+-- > runState (push 1 >> push 2 >> push 3 >> pop >> pop) []+-- (2,[1])++poland :: String -> State [Double] Double+poland "+" = do +    x <- pop+    y <- pop+    push (y + x)+poland "-" = do +    x <- pop+    y <- pop+    push (y - x)+poland "*" = do +    x <- pop+    y <- pop+    push (y * x)+poland "/" = do+    x <- pop+    y <- pop+    push (y / x)+poland x = push (read x :: Double)++poland_calc :: [String] -> (Double, [Double])+poland_calc xs = (cmap poland xs >> pop) >- \x -> runState x []++-- > poland_calc ["1","2","*"]+-- (2.0, [])+-- > poland_calc ["1","2","-"]+-- (-1.0, [])+-- > poland_calc ["1","2","+","3","*"]+-- (9.0, [])+-- > poland_calc ["1","2","+","3","*","3","/"]+-- (3.0, [])+-- > poland_calc ["1","2","+","3","*","0","/"]+-- (Infinity, [])++-----------------------------------------------+-- StateT-Maybe++pushS :: a -> StateT [a] Maybe a+pushS x = do +    xs <- get+    put (x:xs)+    return x++popS :: StateT [a] Maybe a+popS = do +    xs <- get+    put (tail xs)+    return (head xs)++-- > runStateT (pushT 1 >> pushT 2 >> pushT 3) []+-- Just (3,[3,2,1])+-- > runStateT (pushT 1 >> pushT 2 >> pushT 3 >> popT >> popT) []+-- Just (2,[1])++polandS :: String -> StateT [Double] Maybe Double+polandS "+" = do +    x <- popS+    y <- popS+    pushS (y + x)+polandS "-" = do +    x <- popS+    y <- popS+    pushS (y - x)+polandS "*" = do +    x <- popS+    y <- popS+    pushS (y * x)+polandS "/" = do+    x <- popS+    y <- popS+    lift $ guard (x /= 0)+    pushS (y / x)+polandS x = pushS (read x :: Double)++poland_calcS :: [String] -> Maybe (Double, [Double])+poland_calcS xs = (cmap polandS xs >> popS) >- \x -> runStateT x []++-- > poland_calcS ["1","2","*"]+-- Just (2.0, [])+-- > poland_calcS ["1","2","-"]+-- Just (-1.0, [])+-- > poland_calcS ["1","2","+","3","*"]+-- Just (9.0, [])+-- > poland_calcS ["1","2","+","3","*","3","/"]+-- Just (3.0, [])+-- > poland_calcS ["1","2","+","3","*","0","/"]+-- Nothing++-----------------------------------------------+-- MaybeT-StateT-IO Monad++pushMS :: a -> MaybeT (StateT [a] IO) a+pushMS x = do +    xs <- get+    put (x:xs)+    return x+popMS :: MaybeT (StateT [a] IO) a+popMS = do +    xs <- get+    put (tail xs)+    return (head xs)++polandMS :: String -> MaybeT (StateT [Double] IO) Double+polandMS "+" = do +    x <- popMS+    y <- popMS+    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))+    pushMS (y + x)+polandMS "-" = do +    x <- popMS+    y <- popMS+    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))+    pushMS (y - x)+polandMS "*" = do+    x <- popMS+    y <- popMS+    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))+    pushMS (y * x)+polandMS "/" = do+    x <- popMS+    y <- popMS+    liftIO $ putStr (show y ++" / "++ show x ++" = ")+    guard (x /= 0)+    liftIO $ putStr (show (y / x) ++"\n")+    pushMS (y / x)+polandMS x = pushMS (read x :: Double)++poland_calcMS :: [String] -> IO (Maybe Double, [Double])+poland_calcMS xs = (cmap polandMS xs >> popMS) >- runMaybeT+                                               >- \x -> runStateT x []++-- > poland_calcS2 ["1","2","*"]+-- 1.0 * 2.0 = 2.0+-- (Just 2.0, [])++-----------------------------------------------+-- StateT-MaybeT-IO Monad++pushSM :: a -> StateT [a] (MaybeT IO) a+pushSM x = do +    xs <- get+    put (x:xs)+    return x+popSM :: StateT [a] (MaybeT IO) a+popSM = do +    xs <- get+    put (tail xs)+    return (head xs)++polandSM :: String -> StateT [Double] (MaybeT IO) Double+polandSM "+" = do +    x <- popSM+    y <- popSM+    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))+    pushSM (y + x)+polandSM "-" = do +    x <- popSM+    y <- popSM+    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))+    pushSM (y - x)+polandSM "*" = do+    x <- popSM+    y <- popSM+    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))+    pushSM (y * x)+polandSM "/" = do+    x <- popSM+    y <- popSM+    liftIO $ putStr (show y ++" / "++ show x ++" = ")+    guard (x /= 0)+    liftIO $ putStr (show (y / x) ++"\n")+    pushSM (y / x)+polandSM x = pushSM (read x :: Double)++poland_calcSM :: [String] -> IO (Maybe (Double, [Double]))+poland_calcSM xs = (cmap polandSM xs >> popSM) >- \x -> runStateT x []+                                               >- 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++pushS2 :: a -> StateT2 [a] IO Maybe a+pushS2 x = do +    xs <- get+    put (x:xs)+    return x+popS2 :: StateT2 [a] IO Maybe a+popS2 = do +    xs <- get+    put (tail xs)+    return (head xs)++polandS2 :: String -> StateT2 [Double] IO Maybe Double+polandS2 "+" = do +    x <- popS2+    y <- popS2+    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))+    pushS2 (y + x)+polandS2 "-" = do +    x <- popS2+    y <- popS2+    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))+    pushS2 (y - x)+polandS2 "*" = do+    x <- popS2+    y <- popS2+    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))+    pushS2 (y * x)+polandS2 "/" = do+    x <- popS2+    y <- popS2+    liftIO $ putStr (show y ++" / "++ show x ++" = ")+    lift2 $ (*:) $ guard (x /= 0)+    liftIO $ putStr (show (y / x) ++"\n")+    pushS2 (y / x)+polandS2 x = pushS2 (read x :: Double)++poland_calcS2 :: [String] -> IO (Maybe (Double, [Double]))+poland_calcS2 xs = (cmap polandS2 xs >> popS2) >- \x -> runStateT2 x []++-- > 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-MaybeT-ExceptT-IO Monad++pushSME :: a -> StateT [a] (MaybeT (ExceptT () IO)) a+pushSME x = do +    xs <- get+    put (x:xs)+    return x+popSME :: StateT [a] (MaybeT (ExceptT () IO)) a+popSME = do +    xs <- get+    put (tail xs)+    return (head xs)++polandSME :: String -> StateT [Double] (MaybeT (ExceptT () IO)) Double+polandSME "+" = do +    x <- popSME+    y <- popSME+    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))+    pushSME (y + x)+polandSME "-" = do +    x <- popSME+    y <- popSME+    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))+    pushSME (y - x)+polandSME "*" = do+    x <- popSME+    y <- popSME+    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))+    pushSME (y * x)+polandSME "/" = do+    x <- popSME+    y <- popSME+    liftIO $ putStr (show y ++" / "++ show x ++" = ")+    guard (x /= 0)+    liftIO $ putStr (show (y / x) ++"\n")+    pushSME (y / x)+polandSME x = pushSME (read x :: Double)++poland_calcSME :: [String] -> IO (Either () (Maybe (Double, [Double])))+poland_calcSME xs = (cmap polandSME xs >> popSME) >- \x -> runStateT x []+                                                  >- runMaybeT+                                                  >- runExceptT++-----------------------------------------------+-- StateT3-IO-Except-Maybe Monad++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)++polandS3 :: String -> StateT3 [Double] IO (Except ()) Maybe Double+polandS3 s = untransfold3 $ polandSME s++poland_calcS3 :: [String] -> IO (Either () (Maybe (Double, [Double])))+poland_calcS3 xs = (cmap polandS3 xs >> popS3) >- \x -> runStateT3 x []+                                               >- (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+    putStrLn "" >> print "---------------------"+    return ()++tests_Level0 :: Test+tests_Level0 = test [ +      "poland" ~: do+        let actual = poland_calc ["1","2","*"]+        actual @?= (2.0, [])++        let actual = poland_calc ["1","2","+","3","*","3","/"]+        actual @?= (3.0, [])++        --actual <- poland_calc ["1","2","+","3","*","0","/"]+        --actual @?= Infinity+    ]++tests_Level1 :: Test+tests_Level1 = test [ +      "polandT" ~: do+        let actual = poland_calcS ["1","2","*"]+        actual @?= Just (2.0, [])++        let actual = poland_calcS ["1","2","+","3","*","3","/"]+        actual @?= Just (3.0, [])++        let actual = poland_calcS ["1","2","+","3","*","0","/"]+        actual @?= Nothing+    ]++tests_Level1_2 :: Test+tests_Level1_2 = test [ +      "polandMS" ~: do+        actual <- poland_calcMS ["1","2","*"]+        actual @?= (Just 2.0, [])++        actual <- poland_calcMS ["1","2","+","3","*","3","/"]+        actual @?= (Just 3.0, [])++        actual <- poland_calcMS ["1","2","+","3","*","0","/"]+        actual @?= (Nothing, [])+    ]++tests_Level1_3 :: Test+tests_Level1_3 = test [ +      "polandSM" ~: do+        actual <- poland_calcSM ["1","2","*"]+        actual @?= Just (2.0, [])++        actual <- poland_calcSM ["1","2","+","3","*","3","/"]+        actual @?= Just (3.0, [])++        actual <- poland_calcSM ["1","2","+","3","*","0","/"]+        actual @?= Nothing+    ]++tests_Level2 :: Test+tests_Level2 = test [ +      "polandS2" ~: do+        actual <- poland_calcS2 ["1","2","*"]+        actual @?= Just (2.0, [])++        actual <- poland_calcS2 ["1","2","+","3","*","0","/"]+        actual @?= Nothing+    ]++tests_Level2_2 :: Test+tests_Level2_2 = test [ +      "polandS2'" ~: do+        actual <- poland_calcS2' ["1","2","*"]+        actual @?= Just (2.0, [])++        actual <- poland_calcS2' ["1","2","+","3","*","0","/"]+        actual @?= Nothing+    ]++tests_Level3 :: Test+tests_Level3 = test [ +      "polandSME'" ~: do+        actual <- poland_calcSME ["1","2","*"]+        actual @?= Right (Just (2.0, []))++        actual <- poland_calcSME ["1","2","+","3","*","0","/"]+        actual @?= Right Nothing+    ]++tests_Level3_2 :: Test+tests_Level3_2 = test [ +      "polandS3" ~: do+        actual <- poland_calcS3 ["1","2","*"]+        actual @?= Right (Just (2.0, []))++        actual <- poland_calcS3 ["1","2","+","3","*","0","/"]+        actual @?= Right Nothing+    ]+

@@ -0,0 +1,144 @@+import Test.HUnit++import DeepControl.Applicative+import DeepControl.Monad+import DeepControl.Monad.Trans.Writer+import DeepControl.Monad.Trans.Reader++import Control.Monad.Identity++import Safe++main :: IO ()+main = do+    runTestTT $ TestList [+          TestList tLevel0+        , TestList tLevel2+        , TestList tLevel3+        ]+    runTestTT tests_Level0+    putStrLn "" >> print "----------------"+    runTestTT tests_Level2+    putStrLn "" >> print "----------------"+    runTestTT tests_Level3+    putStrLn "" >> print "----------------"+    return ()++tLevel0 = ("Level0" ~:) |$>+    [ (3 >- Just)    ~?= Just 3+    , (Just -< 3)    ~?= Just 3++    , (1 >- (+1) >- (*2) >- (+3))     ~?= 7+    , (1 >- ((+1) >-> (*2) >-> (+3))) ~?= 7+    , (((3+) <-< (2*) <-< (1+)) -< 1) ~?= 7++-- invalid forms+-- ((3+) -< (2*) -< (1+) -< 1)+    ]++tLevel2 = ("Level2" ~:) |$> [+      ([[1]] >>== \x -> [[x]]) ~?= [[1]]+    , ([[1]] >>== \x -> (**:) x) ~?= [[1]]+    , (Just [1] >>== \x -> (**:) x) ~?= Just [1]+    , ([Just 1] >>== \x -> (**:) x) ~?= [Just 1]+    , (Right [1] >>== \x -> (**:) x) ~?= (Right [1] :: Either () [Int])++    , (Right [0] >>== \x -> (**:) (x+1) >>== \x -> (**:) (x+2)) ~?= (Right [3] :: Either () [Int])+    ]++tLevel3 = ("Level3" ~:) |$> [+      ([[[1]]] >>>== \x -> (***:) x) ~?= [[[1]]]+    , ((Just [[1]]) >>>== \x -> (***:) x) ~?= Just [[1]]+    , (([Just [1]]) >>>== \x -> (***:) x) ~?= [Just [1]]+    , (Right (Just [1]) >>>== \x -> (***:) x) ~?= (Right (Just [1]) :: Either () (Maybe [Int]))++    , (Right (Just [0]) >>>== \x -> (***:) (x+1) >>>== \x -> (***:) (x+2)) ~?= (Right (Just [3]) :: Either () (Maybe [Int]))+    , (Right Nothing    >>>== \x -> (***:) (x+1) >>>== \x -> (***:) (x+2)) ~?= (Right Nothing :: Either () (Maybe [Int]))+    ]++tests_Level0 :: Test+tests_Level0 = test [ +      "plus" ~: "(>-)" ~: do+        let plus :: Int -> Int -> Int+            plus x y = +                x >- \a ->+                y >- \b ->+                a + b+        plus 3 4 @?= 7+    ]++tests_Level2 :: Test+tests_Level2 = test [ +      "List-List" ~: "(>>==)" ~: do+        let actual :: [[String]]+            actual = [["a","b"]] >>== \x ->+                     [[0],[1,2]] >>== \y ->+                     (**:) $ x ++ show y+        actual @?= [["a0","b0"],["a0","b1","b2"],["a1","a2","b0"],["a1","a2","b1","b2"]]++    , "List-Maybe" ~: "(>>==), (>>~)" ~: do+        let actual :: [Maybe Double]+            actual = (readMay |$> ["1", "2", "_"]) >>== \a ->+                     (readMay |$> ["0", "2"]) >>== \b ->+                     ((*:) $ guard (b /= 0.0)) >>~+                     (**:) $ a / b+        actual @?= [Just 0.5,Just 1.0,Nothing]+    , "List-Maybe" ~: "(->~)" ~: do+        let actual :: [Maybe Double]+            actual = (readMay |$> ["1", "2", "_"]) >>== \a ->+                     (readMay |$> ["0", "2"]) >>== \b ->+                     guard (b /= 0.0) ->~+                     (**:) $ a / b+        actual @?= [Just 0.5,Just 1.0,Nothing]++    , "(->)-Maybe" ~: "(>-==)" ~: do+        let lengthM :: [Int] -> Maybe Int+            lengthM [] = Nothing+            lengthM xs = Just (length xs) +            averageM :: [Int] -> Maybe Double+            averageM = +                sum >-== \s ->+                lengthM >>== \l ->+                (**:) $ fromIntegral s / fromIntegral l+        averageM [10, 25, 70] @?= Just 35.0+        averageM []           @?= Nothing+    , "Reader-Maybe" ~: do+        let sumR :: Reader [Int] Int+            sumR = sum |$> ask+            lengthRM :: Reader [Int] (Maybe Int)+            lengthRM = ReaderT $ \r -> Identity $ case r of+                                        [] -> Nothing+                                        xs -> Just (length xs) +            averageRM :: Reader [Int] (Maybe Double)+            averageRM = +                sumR >-== \s ->+                lengthRM >>== \l ->+                (**:) $ fromIntegral s / fromIntegral l+        runReader averageRM [10, 25, 70] @?= Just 35.0+        runReader averageRM []           @?= Nothing++    , "Maybe-Writer" ~: "(-*)" ~: do+        let factorial :: Int -> Maybe (Writer [Int] Int)+            factorial n | n < 0  = (-*) Nothing+                        | n == 0 = (*:) $ tell [0] >> return 1+                        | n > 0  = factorial (n-1) >>== \v ->+                                   tell [v] ->~+                                   (**:) (n * v)+        (runWriter |$> factorial 5) @?= Just (120,[0,1,1,2,6,24])++    ]++tests_Level3 :: Test+tests_Level3 = test [ +      "IO-Maybe-Writer" ~: "(>>>==), (-->~), (*-*)" ~: do+        let factorial :: Int -> IO (Maybe (Writer [Int] Int))+            factorial n | n < 0  = (*-*) Nothing+                        | n == 0 = (**:) $ tell [0] >> return 1+                        | n > 0  = factorial (n-1) >>>== \v ->+                                   print v >--~+                                   tell [v] -->~+                                   (***:) (n * v)+        actual <- factorial 5+        (runWriter |$> actual) @?= Just (120,[0,1,1,2,6,24])+    ]+

@@ -0,0 +1,61 @@+import Test.HUnit hiding (State)++import DeepControl.Monad.Morph+import DeepControl.Monad.Trans.State+import DeepControl.Monad.Trans.Writer++-- i.e. :: StateT Int Identity ()+tick    :: State Int ()+tick = modify (+1)++tock                        ::                   StateT Int IO ()+tock = do+    generalize |>| tick     :: (Monad      m) => StateT Int m  ()+    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()++-- λ> runStateT tock 0+-- Tock!+-- ((),1)++-- i.e. :: StateT Int (WriterT [Int] Identity) ()+save    :: StateT Int (Writer  [Int]) ()+save = do+    n <- get+    lift $ tell [n]++program ::                   StateT Int (WriterT [Int] IO) ()+program = replicateM_ 4 $ do+    lift |>| tock+        :: (MonadTrans t) => StateT Int (t             IO) ()+    generalize |>>| save+        :: (Monad      m) => StateT Int (WriterT [Int] m ) ()++-- λ> execWriterT (runStateT program 0)+-- Tock!+-- Tock!+-- Tock!+-- Tock!+-- [1,2,3,4]++----------------------------------------------------------------+-- unit test+----------------------------------------------------------------++main :: IO ()+main = do+    runTestTT tests_+    return ()++tests_ :: Test+tests_ = test [ +      "tock" ~: do+        actual <- runStateT tock 0+        actual @?= ((),1)++    , "program" ~: do+        actual <- execWriterT (runStateT program 0)+        actual @?= [1,2,3,4]+    ]+++

@@ -0,0 +1,61 @@+import Test.HUnit hiding (State)++import DeepControl.Applicative ((|$>))+import DeepControl.Monad (Monad2)+import DeepControl.Monad.Trans (lift, (|*|), (|-*|), (|*-|))+import DeepControl.Monad.Trans.State+import DeepControl.Monad.Trans.Writer++tick :: State Int ()+tick = modify (+1)++tock                        ::                   StateT Int IO ()+tock = do+    (|*|) tick              :: (Monad      m) => StateT Int m  ()+    lift $ putStrLn "Tock!" :: (MonadTrans t) => t          IO ()++-- λ> runStateT tock 0+-- Tock!+-- ((),1)++save    :: StateT Int (Writer [Int]) ()+save = do+    n <- get+    lift $ tell [n]++program ::                   StateT2 Int IO (Writer [Int]) ()+program = replicateM_ 4 $ do+    (|-*|) tock+        :: (Monad2     m) => StateT2 Int IO m              ()+    (|*-|) save+        :: (Monad      m) => StateT2 Int m  (Writer [Int]) ()++-- λ> execWriter |$> runStateT2 program 0+-- Tock!+-- Tock!+-- Tock!+-- Tock!+-- [1,2,3,4]++----------------------------------------------------------------+-- unit test+----------------------------------------------------------------++main :: IO ()+main = do+    runTestTT tests_+    return ()++tests_ :: Test+tests_ = test [ +      "tock" ~: do+        actual <- runStateT tock 0+        actual @?= ((),1)++    , "program" ~: do+        actual <- execWriter |$> runStateT2 program 0+        actual @?= [1,2,3,4]+    ]+++