deepcontrol 0.2.0.0 → 0.3.0.0

raw patch · 26 files changed

+1665/−1701 lines, 26 filesdep +containersdep +mmorphdep +safedep ~basedep ~mtldep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, mmorph, safe

Dependency ranges changed: base, mtl, transformers

API changes (from Hackage documentation)

Files

• DeepControl/Applicative.hs +7/−28
• DeepControl/Monad.hs +35/−30
• DeepControl/Monad/Except.hs +0/−132
• DeepControl/Monad/List.hs +0/−63
• DeepControl/Monad/Maybe.hs +0/−58
• DeepControl/Monad/Morph.hs +135/−0
• DeepControl/Monad/RWS.hs +0/−264
• DeepControl/Monad/Reader.hs +0/−170
• DeepControl/Monad/State.hs +0/−220
• DeepControl/Monad/Trans.hs +105/−0
• DeepControl/Monad/Trans/RWS.hs +149/−0
• DeepControl/Monad/Trans/Reader.hs +94/−0
• DeepControl/Monad/Trans/State.hs +122/−0
• DeepControl/Monad/Trans/Writer.hs +141/−0
• DeepControl/Monad/Writer.hs +0/−233
• DeepControl/MonadTrans.hs +0/−396
• README.md +107/−68
• deepcontrol.cabal +79/−14
• test/UnitTest_Applicative.hs +0/−1
• test/UnitTest_Commutative.hs +30/−0
• test/UnitTest_Monad-Level1.hs +147/−0
• test/UnitTest_Monad-Level2-2.hs +51/−0
• test/UnitTest_Monad-Level2.hs +345/−0
• test/UnitTest_Monad.hs +36/−24
• test/UnitTest_MonadMorph-Level1.hs +60/−0
• test/UnitTest_MonadMorph.hs +22/−0

@@ -310,68 +310,48 @@ infixl 5  *->, <*-, -*>, <-*  -- | The lifted function of @'*>'@, defined as @liftA2 (*>)@.-{-  ----- >>> ((*:)|$> print 1) *>> return [2]+-- >>> ((-*) $ print 1) *>> return [2] -- 1 -- [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)+-- >>> return [2] <<* ((-*) $ print 1) -- 1 -- [2]--- >>> ((*:)|$> print 1) *>> return [3] <<* ((*:)|$> print 2)+-- >>> ((-*) $ print 1) *>> return [3] <<* ((-*) $ print 2) -- 1 -- 2 -- [3]--} (<<*) :: (Applicative f1, Applicative f2) => f1 (f2 a) -> f1 (f2 b) -> f1 (f2 a) (<<*) = liftA2 (<*) --- | Combination consisted of sequence @'*>>'@ and cover @'*:'@, defined as:------ a *-> x = (*:) a *>> x-{-+-- | 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 @'*:'@, defined as:------ x <*- a = x <<* (*:) a-{-+-- | 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 @'-*'@, defined as:------ a -*> x = (-*) a *>> x----{-+-- | Combination consisted of sequence @'*>>'@ and cover @'-*'@. -- -- >>> print [1] -*> return [2] -- [1] -- [2]--} (-*>) :: (Applicative f1, Applicative f2) => f1 a -> f1 (f2 b) -> f1 (f2 b) a -*> x = (-*) a *>> x --- | Combination consisted of sequence @'<<*'@ and cover @'-*'@, defined as:------ x <-* a = x <<* (-*) a-{-+-- | Combination consisted of sequence @'<<*'@ and cover @'-*'@. -- -- >>> return [2] <-* print [1] -- [1]@@ -380,7 +360,6 @@ -- [1] -- [2] -- [3]--} (<-*) :: (Applicative f1, Applicative f2) => f1 (f2 b) -> f1 a -> f1 (f2 b) x <-* a = x <<* (-*) a 

@@ -82,6 +82,17 @@ -- -- >>> 3 >- Just -- Just 3+--+-- >>> :{+-- let plus :: Int -> Int -> Int+--     plus x y = +--         x >- \a ->+--         y >- \b ->+--         a + b+-- in plus 3 4+-- :}+-- 7+-- (>-) :: a -> (a -> b) -> b (>-) = flip (-<) @@ -118,27 +129,25 @@ -- | The 'Monad2' class defines the Monad functions for level-2 types @m1 (m2 a)@; such as [[a]], Maybe [a], Either () (Maybe a), a -> [b], IO [a], etc. --  -- >>> :{+--  -- List-List Monad --  [["a","b"]] >>== \x ->  --  [[0],[1,2]] >>== \y -> ---  (**:) $ x ++ show y+--  (**:) (x ++ show y) -- :} -- [["a0","b0"],["a0","b1","b2"],["a1","a2","b0"],["a1","a2","b1","b2"]] -- -- >>> :{---  let ---    isJust (Just _) = True---    isJust _        = False---    pythagorean_triple :: [Maybe (Int, Int, Int)]  -- List-Maybe Monad---    pythagorean_triple = filter isJust $---        [1..10] >-== \x ->---        [1..10] >-== \y ->---        [1..10] >-== \z ->---        guard (x < y && x*x + y*y == z*z) ->~---        (**:) (x,y,z)---  in pythagorean_triple+--  let lengthM :: [Int] -> Maybe Int   -- ((->) [Int])-Maybe Monad+--      lengthM [] = Nothing+--      lengthM xs = Just (length xs) +--      averageM :: [Int] -> Maybe Double+--      averageM = +--          sum >-== \s ->      -- sum :: [Int] -> Int -- ((->) [Int]) Monad+--          lengthM >>== \l ->+--          (**:) (fromIntegral s / fromIntegral l)+--  in [averageM [10, 25, 70], averageM []] -- :}--- [Just (3,4,5),Just (6,8,10)]--- +-- [Just 35.0,Nothing] --  class (Monad m2) => Monad2 m2 where   -- | Bind function of level-2.@@ -193,23 +202,19 @@ -- | The 'Monad3' class defines the Monad functions for level-3 types @m1 (m2 (m3 a)@. --  -- >>> :{---  let ---    isJust (Just _) = True---    isJust _        = False---    pythagorean_triple :: IO [Maybe (Int, Int, Int)]  -- IO-List-Maybe Monad---    pythagorean_triple = filter isJust |$> (---        [1..10] ->-== \x ->---        [1..10] ->-== \y ->---        [1..10] ->-== \z ->---        guard (x < y && x*x + y*y == z*z) -->~---        print (x,y,z) >--~---        (***:) (x,y,z)---      )---  in pythagorean_triple+-- -- IO-List-List Monad+-- [["a","b"]] ->>== \x ->+-- [[0],[1,2]] ->>== \y ->+-- print (x,y) >--~+-- (***:) (x ++ show y) -- :}--- (3,4,5)--- (6,8,10)--- [Just (3,4,5),Just (6,8,10)]+-- ("a",0)+-- ("a",1)+-- ("a",2)+-- ("b",0)+-- ("b",1)+-- ("b",2)+-- [["a0","b0"],["a0","b1","b2"],["a1","a2","b0"],["a1","a2","b1","b2"]] -- class (Monad m3) => Monad3 m3 where   (>>>==) :: (Monad m1, Monad2 m2) => m1 (m2 (m3 a)) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))

@@ -1,132 +0,0 @@-{-|-Module      : DeepControl.Monad.Except-Description : -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 is just a concise mimic for Except Monad in mtl(monad-transformer-library).-The qualifier "concise" means that this module doesn't make no attempt to transform functions of any kind of Monad automatically.-So when making some new data type of ExceptT, you have to manually define involved Monad instances, -for example `DeepControl.Monad.MonadReader`, `DeepControl.Monad.MonadWriter` or `DeepControl.Monad.MonadState`, -by making use of the transformation functions such as `trans`, `trans2`, etc.-Admittedly it is tedious though, you can deeply understand monad-transformation mechanism instead.--}-{-# LANGUAGE -        DeriveFunctor,-        GeneralizedNewtypeDeriving,-        FlexibleInstances,-        FunctionalDependencies- #-}-module DeepControl.Monad.Except (-    -- * Classes-    Error(..),-    MonadError(..),--    -- * Level-0-    Except(..), mapExcept, withExcept, -    -- * Level-1-    ExceptT(..), mapExceptT, withExceptT, --    ) where --import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.MonadTrans-import DeepControl.Commutative--import Control.Monad.Except (MonadError(..))-import Control.Monad.Signatures-import Data.Monoid--class Error a where-    noMsg  :: a-    noMsg    = strMsg ""-    strMsg :: String -> a-    strMsg _ = noMsg--------------------------------------------------------------------------- Level-0--newtype Except e a = Except { runExcept :: Either e a }-  deriving (Show, Functor, Applicative, Monad, MonadError e) --{- -TODO: 例えば newdata SomeType = ReaderT2 r IO (Except e) a とした場合、 MonadError e SomeType　のインスタンスが作れない（catchError がどうしても作れない）-　　　なので Except の Monadx は作ってもあまり意味がない。-->newtype Eval a = Eval { unEval :: RWST2 Env [String] Int IO (Except ExpError) a }->  deriving (Functor, Applicative, Monad, MonadIO)->->class (Monad2 m2) => MonadError2 e m2 | m2 -> e where->  throwError2 :: (Monad m1) => e -> m1 (m2 a)->  catchError2 :: (Monad m1) => m1 (m2 a) -> (e -> m1 (m2 a)) -> m1 (m2 a)->->instance MonadError2 e Except where->  throwError2     = (*:) . throwError->  catchError2 x h = ->        x >>= \x' -> ->        case x' of->          Right v -> (*:) x'->          Left e  -> catchError e h->->instance MonadError ExpError Eval where->    throwError     = Eval . trans2 . throwError2->    catchError x f = 作れない--instance Monad2 (Except e) where-    m >>== f = (Except |$>) $ (runExcept |$> m) >>== runExcept |$>> f-instance Monad3 (Except e) where-    m >>>== f = (Except |$>>) $ (runExcept |$>> m) >>>== runExcept |$>>> f-instance Monad4 (Except e) where-    m >>>>== f = (Except |$>>>) $ (runExcept |$>>> m) >>>>== runExcept |$>>>> f-instance Monad5 (Except e) where-    m >>>>>== f = (Except |$>>>>) $ (runExcept |$>>>> m) >>>>>== runExcept |$>>>>> f--}--instance Commutative (Except e) where-    commute (Except x) = Except |$> commute x--mapExcept :: (Either e a -> Either e' b) -> Except e a -> Except e' b-mapExcept f = Except . f . runExcept--withExcept :: (e -> e') -> Except e a -> Except e' a-withExcept f = mapExcept $ either (Left . f) Right--------------------------------------------------------------------------- Level-1--newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }--instance (Functor m) => Functor (ExceptT e m) where-    fmap f = \(ExceptT mv) -> ExceptT $ f |$>> mv-instance (Monad m) => Applicative (ExceptT e m) where-    pure a = ExceptT $ (*:) (Right a)-    (<*>)  = ap-instance (Monad m) => Monad (ExceptT e m) where-    return = pure-    m >>= f = ExceptT $ runExceptT m >>== \v -> runExceptT (f v)--instance (Monad m, Error e) => MonadError e (ExceptT e m) where-    throwError = ExceptT . (*:) . Left-    m `catchError` h = ExceptT $ do-        a <- runExceptT m-        case a of-            Left  l -> runExceptT (h l)-            Right r -> (*:) (Right r)--instance MonadTrans (ExceptT e) where-    trans = ExceptT . (-*)-instance (MonadIO m) => MonadIO (ExceptT e m) where-    liftIO = trans . liftIO--mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b-mapExceptT f = ExceptT . f . runExceptT--withExceptT :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a-withExceptT f = mapExceptT $ fmap $ either (Left . f) Right--

@@ -1,63 +0,0 @@-{-|-Module      : DeepControl.Monad.List-Description : -Copyright   : (c) Andy Gill 2001,-              (c) Oregon Graduate Institute of Science and Technology, 2001,-              (C) 2015 KONISHI Yohsuke -License     : BSD-style (see the file LICENSE)-Maintainer  : ocean0yohsuke@gmail.com-Stability   : experimental-Portability : -----This module is just a concise mimic for List Monad in mtl(monad-transformer-library).-The qualifier "concise" means that this module doesn't make no attempt to transform functions of any kind of Monad automatically.-So when making some new data type of ListT, you have to manually define involved Monad instances, -for example `DeepControl.Monad.MonadReader`, `DeepControl.Monad.MonadWriter` or `DeepControl.Monad.MonadState`, -by making use of the transformation functions such as `trans`, `trans2`, etc.-Admittedly it is tedious though, you can deeply understand monad-transformation mechanism instead.--}-module DeepControl.Monad.List (--    -- * Level-1-    ListT(..), mapListT, liftCallCC, liftCatch--    ) where --import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.MonadTrans--import Control.Monad.Signatures--------------------------------------------------------------------------- Level-1--newtype ListT m a = ListT { runListT :: m [a] }--instance (Functor m) => Functor (ListT m) where-    fmap f mv = ListT $ f |$>> runListT mv-instance (Applicative m) => Applicative (ListT m) where-    pure = ListT . (**:)-    f <*> v = ListT $ runListT f |*>> runListT v-instance (Monad m) => Monad (ListT m) where-    return = pure-    mv >>= f = ListT $ -        runListT mv >>== \v ->-        runListT (f v)--instance MonadTrans ListT where-    trans = ListT . (-*)-instance (MonadIO m) => MonadIO (ListT m) where-    liftIO = trans . liftIO--mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b-mapListT f = ListT . f . runListT--liftCallCC :: CallCC m [a] [b] -> CallCC (ListT m) a b-liftCallCC callCC f = ListT $-    callCC $ \c ->-    runListT $ (\a -> ListT $ c [a]) >- f--liftCatch :: Catch e m [a] -> Catch e (ListT m) a-liftCatch catchE m h = ListT $ runListT m `catchE` \e -> runListT (h e)-

@@ -1,58 +0,0 @@-{-|-Module      : DeepControl.Monad.Maybe-Description : -Copyright   : (c) 2007 Yitzak Gale, Eric Kidd,-              (C) 2015 KONISHI Yohsuke-License     : BSD-style (see the file LICENSE)-Maintainer  : ocean0yohsuke@gmail.com-Stability   : experimental-Portability : -----This module is just a concise mimic for Maybe Monad in mtl(monad-transformer-library).-The qualifier "concise" means that this module doesn't make no attempt to transform functions of any kind of Monad automatically.-So when making some new data type of MaybeT, you have to manually define involved Monad instances, -for example `DeepControl.Monad.MonadReader`, `DeepControl.Monad.MonadWriter` or `DeepControl.Monad.MonadState`, -by making use of the transformation functions such as `trans`, `trans2`, etc.-Admittedly it is tedious though, you can deeply understand monad-transformation mechanism instead.--}-module DeepControl.Monad.Maybe (--    -- * Level-1-    MaybeT(..), mapMaybeT, liftCatch,--    ) where --import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.MonadTrans-import DeepControl.Commutative--import Control.Monad.Signatures--------------------------------------------------------------------------- Level-1--newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }--instance (Functor m) => Functor (MaybeT m) where-    fmap f mv = MaybeT $ f |$>> runMaybeT mv-instance (Monad m) => Applicative (MaybeT m) where-    pure = MaybeT . (**:)-    f <*> v = MaybeT $ runMaybeT f |*>> runMaybeT v-instance (Monad m) => Monad (MaybeT m) where-    return = pure-    mv >>= f = MaybeT $ -        runMaybeT mv >>== \v -> -        runMaybeT (f v)--instance MonadTrans MaybeT where-    trans = MaybeT . (-*) -instance (MonadIO m) => MonadIO (MaybeT m) where-    liftIO = trans . liftIO--mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b-mapMaybeT f = MaybeT . f . runMaybeT--liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a-liftCatch catchE m h = MaybeT $ runMaybeT m `catchE` \e -> runMaybeT (h e)-

@@ -0,0 +1,135 @@+{-|+Module      : DeepControl.Monad.Morph+Description : +Copyright   : 2013 Gabriel Gonzalez,+              (C) 2015 KONISHI Yohsuke +License     : BSD-style (see the LICENSE file in the distribution)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module extended mmorph package's Control.Monad.Morph module.+-}+{-# LANGUAGE RankNTypes #-}+module DeepControl.Monad.Morph (+    module Control.Monad.Morph,++    -- * Level-1+    (|>|), (|<|), ++    -- * Level-2+    (|>>|), (|<<|),++    -- * Level-3+    (|>>>|), (|<<<|),++    -- * Level-2 example+    -- $Example_Level2++    ) where ++import DeepControl.Applicative+import DeepControl.Monad.Trans++import Control.Monad.Morph++-------------------------------------------------------------------------------+-- Level-1 functions++infixl 4  |>|+-- | Alias for @'hoist'@.+(|>|) :: (Monad m, MFunctor t) => (forall a . m a -> n a) -> t m b -> t n b+(|>|) = hoist++infixr 4  |<|+-- | 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++-------------------------------------------------------------------------------+-- Level-2 functions++infixl 4  |>>|+(|>>|) :: (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  |<<|+(|<<|) :: (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++-------------------------------------------------------------------------------+-- Level-3 functions++infixl 4  |>>>|+(|>>>|) :: (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  |<<<|+(|<<<|) :: (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++-------------------------------------------------------------------------------+-- TODO++{-+infixr 2  |>>=+class (MFunctor t2, MonadTrans t2) => MMonad2 t2 where+    (|>>=) :: (Monad n, Monad m, MMonad t1) => t1 (t2 m) b -> (forall a . m a -> t1 (t2 n) a) -> t1 (t2 n) b++instance MMonad2 I.IdentityT where+    m |>>= f = (I.runIdentityT |>| m) |>= f++infixr 2  >||>+(>||>) :: (Monad m2, Monad m3, MMonad t1, MMonad2 t2) => +          (forall a. m1 a -> t1 (t2 m2) a) -> (forall b. m2 b -> t1 (t2 m3) b) -> m1 c -> t1 (t2 m3) c+(f >||> g) m = f m |>>= g++-}++----------------------------------------------------------------------+-- Examples++{- $Example_Level2+Here is a monad-morph example, a level-2 monad-morph.++>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]+-}

@@ -1,264 +0,0 @@-{-|-Module      : DeepControl.Monad.RWS-Description : -Copyright   : (C) 2015 KONISHI Yohsuke,-              (c) Andy Gill 2001,-              (c) Oregon Graduate Institute of Science and Technology, 2001-License     : BSD-style (see the file LICENSE)-Maintainer  : ocean0yohsuke@gmail.com-Stability   : experimental-Portability : -----This module is just a concise mimic for RWS Monad in mtl(monad-transformer-library).-The qualifier "concise" means that this module doesn't make no attempt to transform functions of any kind of Monad automatically.-So when making some new data type of RWSTx, you have to manually define involved Monad instances, -for example `DeepControl.Monad.MonadError`, -by making use of the transformation functions such as `trans`, `trans2`, etc.-Admittedly it is tedious though, you can deeply understand monad-transformation mechanism instead.--}-{-# LANGUAGE MultiParamTypeClasses, -             FlexibleInstances #-}-module DeepControl.Monad.RWS (-    MonadReader(..), MonadWriter(..), MonadState(..),--    -- * Level-0-    RWS(..), rws, evalRWS, execRWS, mapRWS, withRWS,-    -- * Level-1-    RWST(..), rwsT, evalRWST, execRWST, mapRWST, withRWST, liftCatch,-    -- * Level-2-    RWST2(..), rwsT2, evalRWST2, execRWST2, mapRWST2, withRWST2, -    -- * Level-3-    RWST3(..), rwsT3, evalRWST3, execRWST3, mapRWST3, withRWST3, --    ) where --import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.MonadTrans--import Control.Monad.Reader (MonadReader(..))-import Control.Monad.Writer (MonadWriter(..))-import Control.Monad.State (MonadState(..))-import Control.Monad.Signatures-import Data.Monoid--------------------------------------------------------------------------- Level-0--newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }--instance Functor (RWS r w s) where-    fmap f m = RWS $ \r s ->-        (\(a, s', w) -> (f a, s', w)) $ runRWS m r s-instance (Monoid w) => Applicative (RWS r w s) where-    pure a = RWS $ \_ s -> (a, s, mempty)-    (<*>)  = ap-instance (Monoid w) => Monad (RWS r w s) where-    return = pure-    m >>= k = RWS $ \r s -> -        runRWS m r s >- \(a, s', w) ->-        runRWS (k a) r s' >- \(b, s'',w') ->-        (b, s'', w <> w')-instance (Monoid w) => MonadReader r (RWS r w s) where-    ask       = RWS $ \r s -> (r, s, mempty)-    local f m = RWS $ \r s -> runRWS m (f r) s-instance (Monoid w) => MonadWriter w (RWS r w s) where-    writer (a, w) = RWS $ \_ s -> (a, s, w)-    tell w        = RWS $ \_ s -> ((),s,w)-    listen m      = RWS $ \r s -> -        runRWS m r s >- \(a, s', w) ->-        ((a, w), s', w)-    pass m        = RWS $ \r s ->-        runRWS m r s >- \((a, f), s', w) ->-        (a, s', f w)-instance (Monoid w) => MonadState s (RWS r w s) where-    get   = RWS $ \_ s -> (s, s, mempty)-    put s = RWS $ \_ _ -> ((), s, mempty)--rws :: (r -> s -> (a, s, w)) -> RWS r w s a-rws = RWS-evalRWS :: RWS r w s a -> r -> s -> (a, w)-evalRWS m r s =-    runRWS m r s >- \(a, _, w) ->-    (a, w)-execRWS :: RWS r w s a -> r -> s -> (s, w)-execRWS m r s =-    runRWS m r s >- \(_, s', w) ->-    (s', w)-mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b-mapRWS f m = RWS $ \r s -> f (runRWS m r s)-withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a-withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)--------------------------------------------------------------------------- Level-1--newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }--instance (Functor m) => Functor (RWST r w s m) where-    fmap f m = RWST $ \r s ->-        (\(a, s', w) -> (f a, s', w)) |$> runRWST m r s-instance (Monoid w, Monad m) => Applicative (RWST r w s m) where-    pure a = RWST $ \_ s -> (*:) (a, s, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m) => Monad (RWST r w s m) where-    return = pure-    m >>= k = RWST $ \r s -> -        runRWST m r s >>= \(a, s', w) ->-        runRWST (k a) r s' >>= \(b, s'',w') ->-        (*:) (b, s'', w <> w')-instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where-    ask       = RWST $ \r s -> (*:) (r, s, mempty)-    local f m = RWST $ \r s -> runRWST m (f r) s-instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where-    writer (a, w) = RWST $ \_ s -> (*:) (a, s, w)-    tell w        = RWST $ \_ s -> (*:) ((), s, w)-    listen m      = RWST $ \r s -> -        runRWST m r s >>= \(a, s', w) ->-        (*:) ((a, w), s', w)-    pass m        = RWST $ \r s ->-        runRWST m r s >>= \((a, f), s', w) ->-        (*:) (a, s', f w)-instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where-    get   = RWST $ \_ s -> (*:) (s, s, mempty)-    put s = RWST $ \_ _ -> (*:) ((), s, mempty)--instance (Monoid w) => MonadTrans (RWST r w s) where-    trans m = RWST $ \r s -> -        m >>= \a ->-        (*:) (a, s, mempty)-instance (Monoid w, MonadIO m, Monad m) => MonadIO (RWST r w s m) where-    liftIO = trans . liftIO--rwsT :: (Monad m) => (r -> s -> (a, s, w)) -> RWST r w s m a-rwsT = RWST . (--*)-evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)-evalRWST m r s =-    runRWST m r s >>= \(a, _, w) ->-    (*:) (a, w)-execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)-execRWST m r s =-    runRWST m r s >>= \(_, s', w) ->-    (*:) (s', w)--mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b-mapRWST f m = RWST $ \r s -> f (runRWST m r s)-withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a-withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)--liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a-liftCatch catchE m h =-    RWST $ \r s -> runRWST m r s `catchE` \e -> runRWST (h e) r s--------------------------------------------------------------------------- Level-2--newtype RWST2 r w s m1 m2 a = RWST2 { runRWST2 :: r -> s -> m1 (m2 (a, s, w)) }--instance (Functor m1, Functor m2) => Functor (RWST2 r w s m1 m2) where-    fmap f m = RWST2 $ \r s ->-        (\(a, s', w) -> (f a, s', w)) |$>> runRWST2 m r s-instance (Monoid w, Monad m1, Monad2 m2) => Applicative (RWST2 r w s m1 m2) where-    pure a = RWST2 $ \_ s -> (**:) (a, s, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2) => Monad (RWST2 r w s m1 m2) where-    return = pure-    m >>= k = RWST2 $ \r s -> -        runRWST2 m r s >>== \(a, s', w) ->-        runRWST2 (k a) r s' >>== \(b, s'',w') ->-        (**:) (b, s'', w <> w')-instance (Monoid w, Monad m1, Monad2 m2) => MonadReader r (RWST2 r w s m1 m2) where-    ask       = RWST2 $ \r s -> (**:) (r, s, mempty)-    local f m = RWST2 $ \r s -> runRWST2 m (f r) s-instance (Monoid w, Monad m1, Monad2 m2) => MonadWriter w (RWST2 r w s m1 m2) where-    writer (a, w) = RWST2 $ \_ s -> (**:) (a, s, w)-    tell w        = RWST2 $ \_ s -> (**:) ((),s,w)-    listen m      = RWST2 $ \r s -> -        runRWST2 m r s >>== \(a, s', w) ->-        (**:) ((a, w), s', w)-    pass m        = RWST2 $ \r s ->-        runRWST2 m r s >>== \((a, f), s', w) ->-        (**:) (a, s', f w)-instance (Monoid w, Monad m1, Monad2 m2) => MonadState s (RWST2 r w s m1 m2) where-    get   = RWST2 $ \_ s -> (**:) (s, s, mempty)-    put s = RWST2 $ \_ _ -> (**:) ((), s, mempty)--instance (Monoid w) => MonadTrans2 (RWST2 r w s) where-    trans2 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--rwsT2 :: (Monad m1, Monad2 m2) => (r -> s -> (a, s, w)) -> RWST2 r w s m1 m2 a-rwsT2 = RWST2 . ((**:)|$>>)-evalRWST2 :: (Monad m1, Monad2 m2) => RWST2 r w s m1 m2 a -> r -> s -> m1 (m2 (a, w))-evalRWST2 m r s =-    runRWST2 m r s >>== \(a, _, w) ->-    (**:) (a, w)-execRWST2 :: (Monad m1, Monad2 m2) => RWST2 r w s m1 m2 a -> r -> s -> m1 (m2 (s, w))-execRWST2 m r s =-    runRWST2 m r s >>== \(_, s', w) ->-    (**:) (s', w)--mapRWST2 :: (m1 (m2 (a, s, w)) -> n1 (n2 (b, s, w'))) -> RWST2 r w s m1 m2 a -> RWST2 r w' s n1 n2 b-mapRWST2 f m = RWST2 $ \r s -> f (runRWST2 m r s)-withRWST2 :: (r' -> s -> (r, s)) -> RWST2 r w s m1 m2 a -> RWST2 r' w s m1 m2 a-withRWST2 f m = RWST2 $ \r s -> uncurry (runRWST2 m) (f r s)--------------------------------------------------------------------------- Level-3--newtype RWST3 r w s m1 m2 m3 a = RWST3 { runRWST3 :: r -> s -> m1 (m2 (m3 (a, s, w))) }--instance (Functor m1, Functor m2, Functor m3) => Functor (RWST3 r w s m1 m2 m3) where-    fmap f m = RWST3 $ \r s ->-        (\(a, s', w) -> (f a, s', w)) |$>>> runRWST3 m r s-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Applicative (RWST3 r w s m1 m2 m3) where-    pure a = RWST3 $ \_ s -> (***:) (a, s, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Monad (RWST3 r w s m1 m2 m3) where-    return = pure-    m >>= k = RWST3 $ \r s -> -        runRWST3 m r s >>>== \(a, s', w) ->-        runRWST3 (k a) r s' >>>== \(b, s'',w') ->-        (***:) (b, s'', w <> w')-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadReader r (RWST3 r w s m1 m2 m3) where-    ask       = RWST3 $ \r s -> (***:) (r, s, mempty)-    local f m = RWST3 $ \r s -> runRWST3 m (f r) s-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadWriter w (RWST3 r w s m1 m2 m3) where-    writer (a, w) = RWST3 $ \_ s -> (***:) (a, s, w)-    tell w        = RWST3 $ \_ s -> (***:) ((), s, w)-    listen m      = RWST3 $ \r s -> -        runRWST3 m r s >>>== \(a, s', w) ->-        (***:) ((a, w), s', w)-    pass m        = RWST3 $ \r s ->-        runRWST3 m r s >>>== \((a, f), s', w) ->-        (***:) (a, s', f w)-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadState s (RWST3 r w s m1 m2 m3) where-    get   = RWST3 $ \_ s -> (***:) (s, s, mempty)-    put s = RWST3 $ \_ _ -> (***:) ((), s, mempty)--instance (Monoid w) => MonadTrans3 (RWST3 r w s) where-    trans3 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--rwsT3 :: (Monad m1, Monad2 m2, Monad3 m3) => (r -> s -> (a, s, w)) -> RWST3 r w s m1 m2 m3 a-rwsT3 = RWST3 . ((***:)|$>>)-evalRWST3 :: (Monad m1, Monad2 m2, Monad3 m3) => RWST3 r w s m1 m2 m3 a -> r -> s -> m1 (m2 (m3 (a, w)))-evalRWST3 m r s =-    runRWST3 m r s >>>== \(a, _, w) ->-    (***:) (a, w)-execRWST3 :: (Monad m1, Monad2 m2, Monad3 m3) => RWST3 r w s m1 m2 m3 a -> r -> s -> m1 (m2 (m3 (s, w)))-execRWST3 m r s =-    runRWST3 m r s >>>== \(_, s', w) ->-    (***:) (s', w)--mapRWST3 :: (m1 (m2 (m3 (a, s, w))) -> n1 (n2 (n3 (b, s, w')))) -> RWST3 r w s m1 m2 m3 a -> RWST3 r w' s n1 n2 n3 b-mapRWST3 f m = RWST3 $ \r s -> f (runRWST3 m r s)-withRWST3 :: (r' -> s -> (r, s)) -> RWST3 r w s m1 m2 m3 a -> RWST3 r' w s m1 m2 m3 a-withRWST3 f m = RWST3 $ \r s -> uncurry (runRWST3 m) (f r s)-

@@ -1,170 +0,0 @@-{-|-Module      : DeepControl.Monad.Reader-Description : -Copyright   : (c) Andy Gill 2001,-              (c) Oregon Graduate Institute of Science and Technology 2001,-              (c) Jeff Newbern 2003-2007,-              (c) Andriy Palamarchuk 2007,-              (C) 2015 KONISHI Yohsuke,-License     : BSD-style (see the file LICENSE)-Maintainer  : ocean0yohsuke@gmail.com-Stability   : experimental-Portability : -----This module is just a concise mimic for Reader Monad in mtl(monad-transformer-library).-The qualifier "concise" means that this module doesn't make no attempt to transform functions of any kind of Monad automatically.-So when making some new data type of ReaderT, you have to manually define involved Monad instances, -for example `DeepControl.Monad.MonadError`, -by making use of the transformation functions such as `trans`, `trans2`, etc.-Admittedly it is tedious though, you can deeply understand monad-transformation mechanism instead.--}-{-# LANGUAGE MultiParamTypeClasses, -             FlexibleInstances #-}-module DeepControl.Monad.Reader (-    MonadReader(..),-    asks,--    -- * Level-0-    Reader(..),-    -- * Level-1-    ReaderT(..), mapReaderT, liftCatch,-    -- * Level-2-    ReaderT2(..), mapReaderT2,-    -- * Level-3-    ReaderT3(..), mapReaderT3,-    -    ) where --import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.MonadTrans--import Control.Monad.Reader (MonadReader(..))-import Control.Monad.Signatures--asks :: MonadReader r m => (r -> a) -> m a-asks = reader--------------------------------------------------------------------------- Level-0--newtype Reader r a = Reader { runReader :: r -> a }--instance Functor (Reader r) where-    fmap f v = Reader $ \r -> -        f $ runReader v r -instance Applicative (Reader r) where-    pure a = Reader $ \_ -> a-    (<*>)  = ap-instance Monad (Reader r) where-    return = pure-    mv >>= f = mv >- \(Reader v) -> Reader $ \r ->-        v r >- \a -> -        runReader (f a) r--{--instance Monad2 (Reader r) where-    -- TODO: Reader を Commutative にできていないため、これは無理-    mmv >>== f = mmv >>= \(Reader v) -> commute $ Reader $ \r ->-        v r >- \a ->-        runReader |$> f a |* r--}  --instance MonadReader r (Reader r) where-    ask       = Reader id-    local f m = Reader $ runReader m . f--------------------------------------------------------------------------- Level-1--newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }--instance (Functor m) => Functor (ReaderT r m) where-    fmap f m = ReaderT $ \r ->-        f |$> runReaderT m r-instance (Monad m) => Applicative (ReaderT s m) where-    pure a = ReaderT $ \_ -> (*:) a-    (<*>)  = ap-instance (Monad m) => Monad (ReaderT r m) where-    return = pure-    (ReaderT v) >>= f = ReaderT $ \r ->-        v r >>= \a -> -        runReaderT (f a) r-instance (Monad m) => MonadReader r (ReaderT r m) where-    ask       = ReaderT $ (*:)-    local f m = ReaderT $ runReaderT m . f--instance MonadTrans (ReaderT r) where-    trans m = ReaderT $ \r -> -        m >>= \a ->-        (*:) a-instance (MonadIO m, Monad m) => MonadIO (ReaderT r m) where-    liftIO = trans . liftIO--mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b-mapReaderT f m = ReaderT $ f . runReaderT m--liftCatch :: Catch e m a -> Catch e (ReaderT r m) a-liftCatch catch m h =-    ReaderT $ \ r -> runReaderT m r `catch` \ e -> runReaderT (h e) r--------------------------------------------------------------------------- Level-2--newtype ReaderT2 r m1 m2 a = ReaderT2 { runReaderT2 :: r -> m1 (m2 a) }--instance (Functor m1, Functor m2) => Functor (ReaderT2 r m1 m2) where-    fmap f m = ReaderT2 $ \r ->-        f |$>> runReaderT2 m r-instance (Monad m1, Monad2 m2) => Applicative (ReaderT2 s m1 m2) where-    pure a = ReaderT2 $ \_ -> (**:) a-    (<*>)  = ap-instance (Monad m1, Monad2 m2) => Monad (ReaderT2 r m1 m2) where-    return = pure-    (ReaderT2 v) >>= f = ReaderT2 $ \r ->-        v r >>== \a -> -        runReaderT2 (f a) r-instance (Monad m1, Monad2 m2) => MonadReader r (ReaderT2 r m1 m2) where-    ask       = ReaderT2 $ (**:)-    local f m = ReaderT2 $ runReaderT2 m . f--instance MonadTrans2 (ReaderT2 r) where-    trans2 m = ReaderT2 $ \r -> -        m >>== \a ->-        (**:) a-instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (ReaderT2 r m1 m2) where-    liftIO = trans2 . (-*) . 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--------------------------------------------------------------------------- Level-3--newtype ReaderT3 r m1 m2 m3 a = ReaderT3 { runReaderT3 :: r -> m1 (m2 (m3 a)) }--instance (Functor m1, Functor m2, Functor m3) => Functor (ReaderT3 r m1 m2 m3) where-    fmap f m = ReaderT3 $ \r ->-        f |$>>> runReaderT3 m r-instance (Monad m1, Monad2 m2, Monad3 m3) => Applicative (ReaderT3 s m1 m2 m3) where-    pure a = ReaderT3 $ \_ -> (***:) a-    (<*>)  = ap-instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (ReaderT3 r m1 m2 m3) where-    return = pure-    (ReaderT3 v) >>= f = ReaderT3 $ \r ->-        v r >>>== \a -> -        runReaderT3 (f a) r-instance (Monad m1, Monad2 m2, Monad3 m3) => MonadReader r (ReaderT3 r m1 m2 m3) where-    ask       = ReaderT3 $ (***:)-    local f m = ReaderT3 $ runReaderT3 m . f--instance MonadTrans3 (ReaderT3 r) where-    trans3 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--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-

@@ -1,220 +0,0 @@-{-|-Module      : DeepControl.Monad.State-Description : -Copyright   : (c) Andy Gill 2001,-              (c) Oregon Graduate Institute of Science and Technology, 2001,-              (C) 2015 KONISHI Yohsuke,-License     : BSD-style (see the file LICENSE)-Maintainer  : ocean0yohsuke@gmail.com-Stability   : experimental-Portability : -----This module is just a concise mimic for State Monad in mtl(monad-transformer-library).-The qualifier "concise" means that this module doesn't make no attempt to transform functions of any kind of Monad automatically.-So when making some new data type of StateT, you have to manually define involved Monad instances, -for example `DeepControl.Monad.MonadError`, -by making use of the transformation functions such as `trans`, `trans2`, etc.-Admittedly it is tedious though, you can deeply understand monad-transformation mechanism instead.--}-{-# LANGUAGE MultiParamTypeClasses,-             FlexibleInstances,-             UndecidableInstances #-}-module DeepControl.Monad.State (-    MonadState(..),-    modify, gets,--    -- * Level-0-    State(..), evalState, execState, mapState, withState,-    -- * Level-1-    StateT(..), evalStateT, execStateT, mapStateT, withStateT, liftCatch,-    -- * Level-2-    StateT2(..), evalStateT2, execStateT2, mapStateT2, withStateT2, -    -- * Level-3-    StateT3(..), evalStateT3, execStateT3, mapStateT3, withStateT3, --    ) where --import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.MonadTrans--import Control.Monad.State (MonadState(..))-import Control.Monad.Signatures--modify :: MonadState s m => (s -> s) -> m ()-modify f = state $ \s -> ((), f s)--gets :: MonadState s m => (s -> a) -> m a-gets f = state $ \s -> (f s, s)--------------------------------------------------------------------------- Level-0--newtype State s a = State { runState :: s -> (a, s) }--instance Functor (State s) where-    fmap f v = State $ \s ->-        (\(a, s') -> (f a, s')) $ runState v s-instance Applicative (State s) where-    pure a = State $ \s -> (a,s) -    (<*>) = ap-instance Monad (State s) where  -    return          = (*:)-    (State v) >>= f = -        State $ \s -> -            v s >- \(a, s') ->-            runState (f a) s'--instance MonadState s (State s) where-    get   = State $ \s -> (s, s)-    put s = State $ \_ -> ((), s)--evalState :: State s a -> s -> a-evalState m s = -    let (a, _) = runState m s-    in a-execState :: State s a -> s -> s-execState m s = -    let (_, s') = runState m s-    in s'--mapState :: ((a, s) -> (b, s)) -> State s a -> State s b-mapState f m = State $ f . runState m-withState :: (s -> s) -> State s a -> State s a-withState f m = State $ runState m . f--------------------------------------------------------------------------- Level-1--newtype StateT s m a = StateT { runStateT :: (s -> m (a,s)) }--instance (Functor m) => Functor (StateT s m) where-    fmap f v = StateT $ \s ->-        (\(a, s') -> (f a, s')) |$> runStateT v s-instance (Monad m) => Applicative (StateT s m) where-    pure a = StateT $ \s -> (*:) (a,s)-    (<*>)  = ap-instance (Monad m) => Monad (StateT s m) where-    return = pure-    (StateT v) >>= f = -        StateT $ \s -> -            v s >>= \(a, s') ->-            runStateT (f a) s'-instance (Monad m) => MonadState s (StateT s m) where-    get   = StateT $ \s -> (*:) (s, s)-    put s = StateT $ \_ -> (*:) ((), s)--instance MonadTrans (StateT s) where-    trans m = StateT $ \s -> -        m >>= \a ->-        (*:) (a, s)-instance (MonadIO m, Monad m) => MonadIO (StateT s m) where-    liftIO = trans . liftIO--evalStateT :: (Monad m) => StateT s m a -> s -> m a-evalStateT m s = -    runStateT m s >>= \(a, _) ->-    (*:) a-execStateT :: (Monad m) => StateT s m a -> s -> m s-execStateT m s = -    runStateT m s >>= \(_, s') ->-    (*:) s'--mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b-mapStateT f m = StateT $ f . runStateT m-withStateT :: (s -> s) -> StateT s m a -> StateT s m a-withStateT f m = StateT $ runStateT m . f--liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a-liftCatch catch m h =-    StateT $ \ s -> runStateT m s `catch` \ e -> runStateT (h e) s--------------------------------------------------------------------------- Level-2--newtype StateT2 s m1 m2 a = StateT2 { runStateT2 :: (s -> m1 (m2 (a,s))) }--instance (Functor m1, Functor m2) => Functor (StateT2 s m1 m2) where-    fmap f v = StateT2 $ \s ->-        (\(a, s') -> (f a, s')) |$>> runStateT2 v s-instance (Monad m1, Monad2 m2) => Applicative (StateT2 s m1 m2) where-    pure a = StateT2 $ \s -> (**:) (a,s)-    (<*>)  = ap-instance (Monad m1, Monad2 m2) => Monad (StateT2 s m1 m2) where-    return = pure-    (StateT2 v) >>= f = -        StateT2 $ \s -> -            v s >>== \(a, s') ->-            runStateT2 (f a) s'-instance (Monad m1, Monad2 m2) => MonadState s (StateT2 s m1 m2) where-    get   = StateT2 $ \s -> (**:) (s, s)-    put s = StateT2 $ \_ -> (**:) ((), s)--instance MonadTrans2 (StateT2 s) where-    trans2 m = StateT2 $ \s -> -        m >>== \a ->-        (**:) (a, s)-instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (StateT2 s m1 m2) where-    liftIO = trans2 . (-*) . liftIO--evalStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 a)-evalStateT2 m s = -    runStateT2 m s >>== \(a, _) ->-    (**:) a-execStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 s)-execStateT2 m s = -    runStateT2 m s >>== \(_, s') ->-    (**:) s'--mapStateT2 :: (m1 (m2 (a, s)) -> n1 (n2 (b, s))) -> StateT2 s m1 m2 a -> StateT2 s n1 n2 b-mapStateT2 f m = StateT2 $ f . runStateT2 m-withStateT2 :: (s -> s) -> StateT2 s m1 m2 a -> StateT2 s m1 m2 a-withStateT2 f m = StateT2 $ runStateT2 m . f--------------------------------------------------------------------------- Level-3--newtype StateT3 s m1 m2 m3 a = StateT3 { runStateT3 :: (s -> m1 (m2 (m3 (a,s)))) }--instance (Functor m1, Functor m2, Functor m3) => Functor (StateT3 s m1 m2 m3) where-    fmap f v = StateT3 $ \s ->-        (\(a, s') -> (f a, s')) |$>>> runStateT3 v s-instance (Monad m1, Monad2 m2, Monad3 m3) => Applicative (StateT3 s m1 m2 m3) where-    pure a = StateT3 $ \s -> (***:) (a,s)-    (<*>)  = ap-instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (StateT3 s m1 m2 m3) where-    return = pure-    (StateT3 v) >>= f = -        StateT3 $ \s -> -            v s >>>== \(a, s') ->-            runStateT3 (f a) s'-instance (Monad m1, Monad2 m2, Monad3 m3) => MonadState s (StateT3 s m1 m2 m3) where-    get   = StateT3 $ \s -> (***:) (s, s)-    put s = StateT3 $ \_ -> (***:) ((), s)--instance MonadTrans3 (StateT3 s) where-    trans3 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--evalStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 a))-evalStateT3 m s = -    runStateT3 m s >>>== \(a, _) ->-    (***:) a-execStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 s))-execStateT3 m s = -    runStateT3 m s >>>== \(_, s') ->-    (***:) s'--mapStateT3 :: (m1 (m2 (m3 (a, s))) -> n1 (n2 (n3 (b, s)))) -> StateT3 s m1 m2 m3 a -> StateT3 s n1 n2 n3 b-mapStateT3 f m = StateT3 $ f . runStateT3 m-withStateT3 :: (s -> s) -> StateT3 s m1 m2 m3 a -> StateT3 s m1 m2 m3 a-withStateT3 f m = StateT3 $ runStateT3 m . f------

@@ -0,0 +1,105 @@+{-|+Module      : DeepControl.Monad.Trans+Description : Enable deep level Monad-Transform programming.+Copyright   : (c) Andy Gill 2001,+              (c) Oregon Graduate Institute of Science and Technology, 2001,+              (C) 2015 KONISHI Yohsuke+License     : BSD-style (see the file LICENSE)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module enables you to program in Monad-Transformer style for more __deeper__ level than the usual @Control.Monad.Trans@ module expresses.+You would realize exactly what __/more deeper level/__ means by reading the example codes, which are attached on the page bottom.+Note: all the MonadTransx instances for Level-4 and Level-5 haven't been written yet.+-}+module DeepControl.Monad.Trans (+    -- * MonadIO+    MonadIO(..),++    -- * MonadTrans+    trans,+    MonadTrans(..),+    MonadTrans2(..),+    MonadTrans3(..),+    MonadTrans4(..),+    MonadTrans5(..),++    -- * Level-2 example+    -- $Example_Level2++) where++import           DeepControl.Monad++import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class (MonadTrans (..))++----------------------------------------------------------------------+-- Level-1++-- | Alias for @'Control.Monad.Trans.Class.lift'@.+trans :: (Monad m, MonadTrans t) => m a -> t m a+trans = lift++----------------------------------------------------------------------+-- Level-2++class  MonadTrans2 t  where+    trans2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a++----------------------------------------------------------------------+-- Level-3++class  MonadTrans3 t  where+    trans3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a++----------------------------------------------------------------------+-- 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++----------------------------------------------------------------------+-- 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++----------------------------------------------------------------------+-- Examples++{- $Example_Level2+Here is a monad transformer example how to implement Ackermann function, improved to stop within a certain limit of time, with ReaderT2-IO-Maybe monad, a level-2 monad-transformation.++>import DeepControl.Applicative+>import DeepControl.Commutative (commute)+>import DeepControl.Monad ((>-))+>import DeepControl.Monad.Trans (trans2)+>import DeepControl.Monad.Trans.Reader+>+>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)+>  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 $ ackermann timelimit x y               -- transform(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+>+>-- λ> commute $ calc_ackermann 1000 |$> [0..4] |* 4+>-- [Just 5,Just 6,Just 11,Just 125,Nothing]+-}

@@ -0,0 +1,149 @@+{-|+Module      : DeepControl.Monad.Trans.RWS+Description : +Copyright   : (C) 2015 KONISHI Yohsuke,+              (c) Andy Gill 2001,+              (c) Oregon Graduate Institute of Science and Technology, 2001+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 MultiParamTypeClasses, +             FlexibleInstances #-}+module DeepControl.Monad.Trans.RWS (+    module Control.Monad.RWS,+    MonadReader(..), MonadWriter(..), MonadState(..),++    -- * Level-2+    RWST2(..), rwsT2, evalRWST2, execRWST2, mapRWST2, withRWST2, +    -- * Level-3+    RWST3(..), rwsT3, evalRWST3, execRWST3, mapRWST3, withRWST3, ++    ) where ++import DeepControl.Applicative+import DeepControl.Monad+import DeepControl.Monad.Trans++import Control.Monad.Reader (MonadReader(..))+import Control.Monad.Writer (MonadWriter(..))+import Control.Monad.State (MonadState(..))+import Control.Monad.RWS+import Control.Monad.Signatures+import Data.Monoid++----------------------------------------------------------------------+-- Level-2++newtype RWST2 r w s m1 m2 a = RWST2 { runRWST2 :: r -> s -> m1 (m2 (a, s, w)) }++instance (Functor m1, Functor m2) => Functor (RWST2 r w s m1 m2) where+    fmap f m = RWST2 $ \r s ->+        (\(a, s', w) -> (f a, s', w)) |$>> runRWST2 m r s+instance (Monoid w, Monad m1, Monad2 m2) => Applicative (RWST2 r w s m1 m2) where+    pure a = RWST2 $ \_ s -> (**:) (a, s, mempty)+    (<*>)  = ap+instance (Monoid w, Monad m1, Monad2 m2) => Monad (RWST2 r w s m1 m2) where+    return = pure+    m >>= k = RWST2 $ \r s -> +        runRWST2 m r s >>== \(a, s', w) ->+        runRWST2 (k a) r s' >>== \(b, s'',w') ->+        (**:) (b, s'', w <> w')+instance (Monoid w, Monad m1, Monad2 m2) => MonadReader r (RWST2 r w s m1 m2) where+    ask       = RWST2 $ \r s -> (**:) (r, s, mempty)+    local f m = RWST2 $ \r s -> runRWST2 m (f r) s+instance (Monoid w, Monad m1, Monad2 m2) => MonadWriter w (RWST2 r w s m1 m2) where+    writer (a, w) = RWST2 $ \_ s -> (**:) (a, s, w)+    tell w        = RWST2 $ \_ s -> (**:) ((),s,w)+    listen m      = RWST2 $ \r s -> +        runRWST2 m r s >>== \(a, s', w) ->+        (**:) ((a, w), s', w)+    pass m        = RWST2 $ \r s ->+        runRWST2 m r s >>== \((a, f), s', w) ->+        (**:) (a, s', f w)+instance (Monoid w, Monad m1, Monad2 m2) => MonadState s (RWST2 r w s m1 m2) where+    get   = RWST2 $ \_ s -> (**:) (s, s, mempty)+    put s = RWST2 $ \_ _ -> (**:) ((), s, mempty)++instance (Monoid w) => MonadTrans2 (RWST2 r w s) where+    trans2 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++rwsT2 :: (Monad m1, Monad2 m2) => (r -> s -> (a, s, w)) -> RWST2 r w s m1 m2 a+rwsT2 = RWST2 . ((**:)|$>>)+evalRWST2 :: (Monad m1, Monad2 m2) => RWST2 r w s m1 m2 a -> r -> s -> m1 (m2 (a, w))+evalRWST2 m r s =+    runRWST2 m r s >>== \(a, _, w) ->+    (**:) (a, w)+execRWST2 :: (Monad m1, Monad2 m2) => RWST2 r w s m1 m2 a -> r -> s -> m1 (m2 (s, w))+execRWST2 m r s =+    runRWST2 m r s >>== \(_, s', w) ->+    (**:) (s', w)++mapRWST2 :: (m1 (m2 (a, s, w)) -> n1 (n2 (b, s, w'))) -> RWST2 r w s m1 m2 a -> RWST2 r w' s n1 n2 b+mapRWST2 f m = RWST2 $ \r s -> f (runRWST2 m r s)+withRWST2 :: (r' -> s -> (r, s)) -> RWST2 r w s m1 m2 a -> RWST2 r' w s m1 m2 a+withRWST2 f m = RWST2 $ \r s -> uncurry (runRWST2 m) (f r s)++----------------------------------------------------------------------+-- Level-3++newtype RWST3 r w s m1 m2 m3 a = RWST3 { runRWST3 :: r -> s -> m1 (m2 (m3 (a, s, w))) }++instance (Functor m1, Functor m2, Functor m3) => Functor (RWST3 r w s m1 m2 m3) where+    fmap f m = RWST3 $ \r s ->+        (\(a, s', w) -> (f a, s', w)) |$>>> runRWST3 m r s+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Applicative (RWST3 r w s m1 m2 m3) where+    pure a = RWST3 $ \_ s -> (***:) (a, s, mempty)+    (<*>)  = ap+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Monad (RWST3 r w s m1 m2 m3) where+    return = pure+    m >>= k = RWST3 $ \r s -> +        runRWST3 m r s >>>== \(a, s', w) ->+        runRWST3 (k a) r s' >>>== \(b, s'',w') ->+        (***:) (b, s'', w <> w')+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadReader r (RWST3 r w s m1 m2 m3) where+    ask       = RWST3 $ \r s -> (***:) (r, s, mempty)+    local f m = RWST3 $ \r s -> runRWST3 m (f r) s+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadWriter w (RWST3 r w s m1 m2 m3) where+    writer (a, w) = RWST3 $ \_ s -> (***:) (a, s, w)+    tell w        = RWST3 $ \_ s -> (***:) ((), s, w)+    listen m      = RWST3 $ \r s -> +        runRWST3 m r s >>>== \(a, s', w) ->+        (***:) ((a, w), s', w)+    pass m        = RWST3 $ \r s ->+        runRWST3 m r s >>>== \((a, f), s', w) ->+        (***:) (a, s', f w)+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadState s (RWST3 r w s m1 m2 m3) where+    get   = RWST3 $ \_ s -> (***:) (s, s, mempty)+    put s = RWST3 $ \_ _ -> (***:) ((), s, mempty)++instance (Monoid w) => MonadTrans3 (RWST3 r w s) where+    trans3 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++rwsT3 :: (Monad m1, Monad2 m2, Monad3 m3) => (r -> s -> (a, s, w)) -> RWST3 r w s m1 m2 m3 a+rwsT3 = RWST3 . ((***:)|$>>)+evalRWST3 :: (Monad m1, Monad2 m2, Monad3 m3) => RWST3 r w s m1 m2 m3 a -> r -> s -> m1 (m2 (m3 (a, w)))+evalRWST3 m r s =+    runRWST3 m r s >>>== \(a, _, w) ->+    (***:) (a, w)+execRWST3 :: (Monad m1, Monad2 m2, Monad3 m3) => RWST3 r w s m1 m2 m3 a -> r -> s -> m1 (m2 (m3 (s, w)))+execRWST3 m r s =+    runRWST3 m r s >>>== \(_, s', w) ->+    (***:) (s', w)++mapRWST3 :: (m1 (m2 (m3 (a, s, w))) -> n1 (n2 (n3 (b, s, w')))) -> RWST3 r w s m1 m2 m3 a -> RWST3 r w' s n1 n2 n3 b+mapRWST3 f m = RWST3 $ \r s -> f (runRWST3 m r s)+withRWST3 :: (r' -> s -> (r, s)) -> RWST3 r w s m1 m2 m3 a -> RWST3 r' w s m1 m2 m3 a+withRWST3 f m = RWST3 $ \r s -> uncurry (runRWST3 m) (f r s)+

@@ -0,0 +1,94 @@+{-|+Module      : DeepControl.Monad.Trans.Reader+Description : +Copyright   : (c) Andy Gill 2001,+              (c) Oregon Graduate Institute of Science and Technology 2001,+              (c) Jeff Newbern 2003-2007,+              (c) Andriy Palamarchuk 2007,+              (C) 2015 KONISHI Yohsuke,+License     : BSD-style (see the file LICENSE)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module extended Reader Monad in mtl(monad-transformer-library).+-}+{-# LANGUAGE MultiParamTypeClasses, +             FlexibleInstances #-}+module DeepControl.Monad.Trans.Reader (+    module Control.Monad.Reader,++    -- * Level-2+    ReaderT2(..), mapReaderT2,+    -- * Level-3+    ReaderT3(..), mapReaderT3,+    +    ) where ++import DeepControl.Applicative+import DeepControl.Monad+import DeepControl.Monad.Trans++import Control.Monad.Reader +import Control.Monad.Signatures++----------------------------------------------------------------------+-- Level-2++newtype ReaderT2 r m1 m2 a = ReaderT2 { runReaderT2 :: r -> m1 (m2 a) }++instance (Functor m1, Functor m2) => Functor (ReaderT2 r m1 m2) where+    fmap f m = ReaderT2 $ \r ->+        f |$>> runReaderT2 m r+instance (Monad m1, Monad2 m2) => Applicative (ReaderT2 s m1 m2) where+    pure a = ReaderT2 $ \_ -> (**:) a+    (<*>)  = ap+instance (Monad m1, Monad2 m2) => Monad (ReaderT2 r m1 m2) where+    return = pure+    (ReaderT2 v) >>= f = ReaderT2 $ \r ->+        v r >>== \a -> +        runReaderT2 (f a) r+instance (Monad m1, Monad2 m2) => MonadReader r (ReaderT2 r m1 m2) where+    ask       = ReaderT2 $ (**:)+    local f m = ReaderT2 $ runReaderT2 m . f++instance MonadTrans2 (ReaderT2 r) where+    trans2 m = ReaderT2 $ \r -> +        m >>== \a ->+        (**:) a+instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (ReaderT2 r m1 m2) where+    liftIO = trans2 . (-*) . 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++----------------------------------------------------------------------+-- Level-3++newtype ReaderT3 r m1 m2 m3 a = ReaderT3 { runReaderT3 :: r -> m1 (m2 (m3 a)) }++instance (Functor m1, Functor m2, Functor m3) => Functor (ReaderT3 r m1 m2 m3) where+    fmap f m = ReaderT3 $ \r ->+        f |$>>> runReaderT3 m r+instance (Monad m1, Monad2 m2, Monad3 m3) => Applicative (ReaderT3 s m1 m2 m3) where+    pure a = ReaderT3 $ \_ -> (***:) a+    (<*>)  = ap+instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (ReaderT3 r m1 m2 m3) where+    return = pure+    (ReaderT3 v) >>= f = ReaderT3 $ \r ->+        v r >>>== \a -> +        runReaderT3 (f a) r+instance (Monad m1, Monad2 m2, Monad3 m3) => MonadReader r (ReaderT3 r m1 m2 m3) where+    ask       = ReaderT3 $ (***:)+    local f m = ReaderT3 $ runReaderT3 m . f++instance MonadTrans3 (ReaderT3 r) where+    trans3 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++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+

@@ -0,0 +1,122 @@+{-|+Module      : DeepControl.Monad.Trans.State+Description : +Copyright   : (c) Andy Gill 2001,+              (c) Oregon Graduate Institute of Science and Technology, 2001,+              (C) 2015 KONISHI Yohsuke,+License     : BSD-style (see the file LICENSE)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module extended State Monad in mtl(monad-transformer-library).+-}+{-# LANGUAGE MultiParamTypeClasses,+             FlexibleInstances,+             UndecidableInstances #-}+module DeepControl.Monad.Trans.State (+    module Control.Monad.State,++    -- * Level-2+    StateT2(..), evalStateT2, execStateT2, mapStateT2, withStateT2, +    -- * Level-3+    StateT3(..), evalStateT3, execStateT3, mapStateT3, withStateT3, ++    ) where ++import DeepControl.Applicative+import DeepControl.Monad+import DeepControl.Monad.Trans++import Control.Monad.State +import Control.Monad.Signatures++----------------------------------------------------------------------+-- Level-2++newtype StateT2 s m1 m2 a = StateT2 { runStateT2 :: (s -> m1 (m2 (a,s))) }++instance (Functor m1, Functor m2) => Functor (StateT2 s m1 m2) where+    fmap f v = StateT2 $ \s ->+        (\(a, s') -> (f a, s')) |$>> runStateT2 v s+instance (Monad m1, Monad2 m2) => Applicative (StateT2 s m1 m2) where+    pure a = StateT2 $ \s -> (**:) (a,s)+    (<*>)  = ap+instance (Monad m1, Monad2 m2) => Monad (StateT2 s m1 m2) where+    return = pure+    (StateT2 v) >>= f = +        StateT2 $ \s -> +            v s >>== \(a, s') ->+            runStateT2 (f a) s'+instance (Monad m1, Monad2 m2) => MonadState s (StateT2 s m1 m2) where+    get   = StateT2 $ \s -> (**:) (s, s)+    put s = StateT2 $ \_ -> (**:) ((), s)++instance MonadTrans2 (StateT2 s) where+    trans2 m = StateT2 $ \s -> +        m >>== \a ->+        (**:) (a, s)+instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (StateT2 s m1 m2) where+    liftIO = trans2 . (-*) . liftIO++evalStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 a)+evalStateT2 m s = +    runStateT2 m s >>== \(a, _) ->+    (**:) a+execStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 s)+execStateT2 m s = +    runStateT2 m s >>== \(_, s') ->+    (**:) s'++mapStateT2 :: (m1 (m2 (a, s)) -> n1 (n2 (b, s))) -> StateT2 s m1 m2 a -> StateT2 s n1 n2 b+mapStateT2 f m = StateT2 $ f . runStateT2 m+withStateT2 :: (s -> s) -> StateT2 s m1 m2 a -> StateT2 s m1 m2 a+withStateT2 f m = StateT2 $ runStateT2 m . f++----------------------------------------------------------------------+-- Level-3++newtype StateT3 s m1 m2 m3 a = StateT3 { runStateT3 :: (s -> m1 (m2 (m3 (a,s)))) }++instance (Functor m1, Functor m2, Functor m3) => Functor (StateT3 s m1 m2 m3) where+    fmap f v = StateT3 $ \s ->+        (\(a, s') -> (f a, s')) |$>>> runStateT3 v s+instance (Monad m1, Monad2 m2, Monad3 m3) => Applicative (StateT3 s m1 m2 m3) where+    pure a = StateT3 $ \s -> (***:) (a,s)+    (<*>)  = ap+instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (StateT3 s m1 m2 m3) where+    return = pure+    (StateT3 v) >>= f = +        StateT3 $ \s -> +            v s >>>== \(a, s') ->+            runStateT3 (f a) s'+instance (Monad m1, Monad2 m2, Monad3 m3) => MonadState s (StateT3 s m1 m2 m3) where+    get   = StateT3 $ \s -> (***:) (s, s)+    put s = StateT3 $ \_ -> (***:) ((), s)++instance MonadTrans3 (StateT3 s) where+    trans3 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++evalStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 a))+evalStateT3 m s = +    runStateT3 m s >>>== \(a, _) ->+    (***:) a+execStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 s))+execStateT3 m s = +    runStateT3 m s >>>== \(_, s') ->+    (***:) s'++mapStateT3 :: (m1 (m2 (m3 (a, s))) -> n1 (n2 (n3 (b, s)))) -> StateT3 s m1 m2 m3 a -> StateT3 s n1 n2 n3 b+mapStateT3 f m = StateT3 $ f . runStateT3 m+withStateT3 :: (s -> s) -> StateT3 s m1 m2 m3 a -> StateT3 s m1 m2 m3 a+withStateT3 f m = StateT3 $ runStateT3 m . f++++++

@@ -0,0 +1,141 @@+{-|+Module      : DeepControl.Monad.Trans.State+Description : +Copyright   : (c) Andy Gill 2001,+              (c) Oregon Graduate Institute of Science and Technology, 2001,+              (C) 2015 KONISHI Yohsuke,+License     : BSD-style (see the file LICENSE)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module extended Writer Monad in mtl(monad-transformer-library).+-}+{-# LANGUAGE MultiParamTypeClasses, +             FlexibleInstances #-}+module DeepControl.Monad.Trans.Writer (+    module Control.Monad.Writer,++    -- * Level-2+    WriterT2(..), execWriterT2, mapWriterT2,+    -- * Level-3+    WriterT3(..), execWriterT3, mapWriterT3,++    ) where ++import DeepControl.Applicative+import DeepControl.Monad+import DeepControl.Monad.Trans++import Control.Monad.Writer+import Control.Monad.Signatures+import Data.Monoid+import Control.Monad.Identity++----------------------------------------------------------------------+-- Level-1++instance (Monoid w) => Monad2 (Writer w) where+    mv >>== f = +        mv >>= \x -> runWriterT x >- \(Identity (a, w)) ->+        f a <$| (\x -> runWriterT x >- \(Identity (b, w')) ->+                       WriterT $ Identity (b, w <> w'))+instance (Monoid w) => Monad3 (Writer w) where+    mv >>>== f = +        mv >>== \x -> runWriterT x >- \(Identity (a, w)) ->+        f a <<$| (\x -> runWriterT x >- \(Identity (b, w')) ->+                        WriterT $ Identity (b, w <> w'))+instance (Monoid w) => Monad4 (Writer w) where+    mv >>>>== f = +        mv >>>== \x -> runWriterT x >- \(Identity (a, w)) ->+        f a <<<$| (\x -> runWriterT x >- \(Identity (b, w')) ->+                         WriterT $ Identity (b, w <> w'))+instance (Monoid w) => Monad5 (Writer w) where+    mv >>>>>== f = +        mv >>>>== \x -> runWriterT x >- \(Identity (a, w)) ->+        f a <<<<$| (\x -> runWriterT x >- \(Identity (b, w')) ->+                          WriterT $ Identity (b, w <> w'))++----------------------------------------------------------------------+-- Level-2++newtype WriterT2 w m1 m2 a = WriterT2 { runWriterT2 :: m1 (m2 (a, w)) }++instance (Monad m1, Monad2 m2) => Functor (WriterT2 w m1 m2) where+    fmap f v = WriterT2 $ (\(a, w) -> (f a, w)) |$>> (runWriterT2 v)+instance (Monoid w, Monad m1, Monad2 m2) => Applicative (WriterT2 w m1 m2) where+    pure a = WriterT2 $ (**:) (a, mempty)+    (<*>)  = ap+instance (Monoid w, Monad m1, Monad2 m2) => Monad (WriterT2 w m1 m2) where  +    return = pure+    (WriterT2 v) >>= f = WriterT2 $+        v >>== \(a, w) ->+        runWriterT2 (f a) >>== \(a', w') ->+        (**:) (a', w <> w')+instance (Monoid w, Monad m1, Monad2 m2) => MonadWriter w (WriterT2 w m1 m2) where+    writer   = WriterT2 . (**:)+    tell w   = writer $ ((), w)+    listen m = WriterT2 $+        runWriterT2 m >>== \(a, w) ->+        (**:) ((a, w), w) +    pass m   = WriterT2 $+        runWriterT2 m >>== \((a, f), w) ->+        (**:) (a, f w)++instance (Monoid w) => MonadTrans2 (WriterT2 w) where+    trans2 m = WriterT2 $ +        m >>== \a ->+        (**:) (a, mempty)+instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (WriterT2 w m1 m2) where+    liftIO = trans2 . (-*) . liftIO++execWriterT2 :: (Monad m1, Monad2 m2) => WriterT2 w m1 m2 a -> m1 (m2 w)+execWriterT2 m =+    runWriterT2 m >>== \(_, w) ->+    (**:) w++mapWriterT2 :: (m1 (m2 (a, w)) -> n1 (n2 (b, w'))) -> WriterT2 w m1 m2 a -> WriterT2 w' n1 n2 b+mapWriterT2 f m = WriterT2 $ f (runWriterT2 m)++----------------------------------------------------------------------+-- Level-3++newtype WriterT3 w m1 m2 m3 a = WriterT3 { runWriterT3 :: m1 (m2 (m3 (a, w))) }++instance (Monad m1, Monad2 m2, Monad3 m3) => Functor (WriterT3 w m1 m2 m3) where+    fmap f v = WriterT3 $ (\(a, w) -> (f a, w)) |$>>> (runWriterT3 v)+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Applicative (WriterT3 w m1 m2 m3) where+    pure a = WriterT3 $ (***:) (a, mempty)+    (<*>)  = ap+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Monad (WriterT3 w m1 m2 m3) where  +    return = pure+    (WriterT3 v) >>= f = WriterT3 $+        v >>>== \(a, w) ->+        runWriterT3 (f a) >>>== \(a', w') ->+        (***:) (a', w <> w')+instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadWriter w (WriterT3 w m1 m2 m3) where+    writer   = WriterT3 . (***:)+    tell w   = writer $ ((), w)+    listen m = WriterT3 $+        runWriterT3 m >>>== \(a, w) ->+        (***:) ((a, w), w) +    pass m   = WriterT3 $+        runWriterT3 m >>>== \((a, f), w) ->+        (***:) (a, f w)++instance (Monoid w) => MonadTrans3 (WriterT3 w) where+    trans3 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++execWriterT3 :: (Monad m1, Monad2 m2, Monad3 m3) => WriterT3 w m1 m2 m3 a -> m1 (m2 (m3 w))+execWriterT3 m =+    runWriterT3 m >>>== \(_, w) ->+    (***:) w++mapWriterT3 :: (m1 (m2 (m3 (a, w))) -> n1 (n2 (n3 (b, w')))) -> WriterT3 w m1 m2 m3 a -> WriterT3 w' n1 n2 n3 b+mapWriterT3 f m = WriterT3 $ f (runWriterT3 m)++

@@ -1,233 +0,0 @@-{-|-Module      : DeepControl.Monad.State-Description : -Copyright   : (c) Andy Gill 2001,-              (c) Oregon Graduate Institute of Science and Technology, 2001,-              (C) 2015 KONISHI Yohsuke,-License     : BSD-style (see the file LICENSE)-Maintainer  : ocean0yohsuke@gmail.com-Stability   : experimental-Portability : -----This module is just a concise mimic for Reader Monad in mtl(monad-transformer-library).-The qualifier "concise" means that this module doesn't make no attempt to transform functions of any kind of Monad automatically.-So when making some new data type of WriterT, you have to manually define involved Monad instances, -for example `DeepControl.Monad.MonadError`, -by making use of the transformation functions such as `trans`, `trans2`, etc.-Admittedly it is tedious though, you can deeply understand monad-transformation mechanism instead.--}-{-# LANGUAGE MultiParamTypeClasses, -             FlexibleInstances #-}-module DeepControl.Monad.Writer (-    MonadWriter(..),-    listens, censor,--    -- * Level-0-    Writer(..), execWriter, mapWriter,-    -- * Level-1-    WriterT(..), execWriterT, mapWriterT, liftCatch,-    -- * Level-2-    WriterT2(..), execWriterT2, mapWriterT2,-    -- * Level-3-    WriterT3(..), execWriterT3, mapWriterT3,--    ) where --import DeepControl.Applicative-import DeepControl.Monad-import DeepControl.MonadTrans--import Control.Monad.Writer (MonadWriter(..))-import Control.Monad.Signatures-import Data.Monoid--listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b)-listens f m = do-    (a, w) <- listen m-    return (a, f w)--censor :: MonadWriter w m => (w -> w) -> m a -> m a-censor f m = pass $ do-    a <- m-    return (a, f)--------------------------------------------------------------------------- Level-0--newtype Writer w a = Writer { runWriter :: (a, w) }--instance Functor (Writer w) where-    fmap f v = Writer $ (\(a, w) -> (f a, w)) $ (runWriter v)-instance (Monoid w) => Applicative (Writer w) where-    pure a = Writer $ (a, mempty)-    (<*>) = \(Writer (f, w)) (Writer (a, w')) ->-        Writer (f a, w <> w')--instance (Monoid w) => Monad (Writer w) where-    return = pure-    mv >>= f = -        mv >- \(Writer (a, w)) -> -        (\(Writer (b, w')) -> Writer (b, w <> w')) $ f a-instance (Monoid w) => Monad2 (Writer w) where-    mmv >>== f = -        mmv >>= \(Writer (a, w)) -> -        (\(Writer (b, w')) -> Writer (b, w <> w')) |$> f a-instance (Monoid w) => Monad3 (Writer w) where-    mmv >>>== f = -        mmv >>== \(Writer (a, w)) -> -        (\(Writer (b, w')) -> Writer (b, w <> w')) |$>> f a-instance (Monoid w) => Monad4 (Writer w) where-    mmv >>>>== f = -        mmv >>>== \(Writer (a, w)) -> -        (\(Writer (b, w')) -> Writer (b, w <> w')) |$>>> f a-instance (Monoid w) => Monad5 (Writer w) where-    mmv >>>>>== f = -        mmv >>>>== \(Writer (a, w)) -> -        (\(Writer (b, w')) -> Writer (b, w <> w')) |$>>>> f a--instance (Monoid w) => MonadWriter w (Writer w) where-    writer   = Writer-    tell w   = writer ((), w)-    listen m = Writer $ -        runWriter m >- \(a, w) ->-        ((a, w), w) -    pass m   = Writer $ -        runWriter m >- \((a, f), w) ->-        (a, f w)--execWriter :: Writer w a -> w-execWriter m =-    runWriter m >- \(_, w) ->-    w--mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b-mapWriter f m = Writer $ f (runWriter m)--------------------------------------------------------------------------- Level-1--newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }--instance (Monad m) => Functor (WriterT w m) where-    fmap f v = WriterT $ (\(a, w) -> (f a, w)) |$> (runWriterT v)-instance (Monoid w, Monad m) => Applicative (WriterT w m) where-    pure a = WriterT $ (*:) (a, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m) => Monad (WriterT w m) where  -    return = pure-    (WriterT v) >>= f = WriterT $-        v >>= \(a, w) ->-        runWriterT (f a) >>= \(a', w') ->-        (*:) (a', w <> w')-instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where-    writer   = WriterT . (*:)-    tell w   = writer $ ((), w)-    listen m = WriterT $-        runWriterT m >>= \(a, w) ->-        (*:) ((a, w), w) -    pass m   = WriterT $-        runWriterT m >>= \((a, f), w) ->-        (*:) (a, f w)--instance (Monoid w) => MonadTrans (WriterT w) where-    trans m = WriterT $ -        m >>= \a ->-        (*:) (a, mempty)-instance (Monoid w, MonadIO m, Monad m) => MonadIO (WriterT w m) where-    liftIO = trans . liftIO--execWriterT :: (Monad m) => WriterT w m a -> m w-execWriterT m =-    runWriterT m >>= \(_, w) ->-    (*:) w--mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b-mapWriterT f m = WriterT $ f (runWriterT m)--liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a-liftCatch catchE m h =-    WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e)--------------------------------------------------------------------------- Level-2--newtype WriterT2 w m1 m2 a = WriterT2 { runWriterT2 :: m1 (m2 (a, w)) }--instance (Monad m1, Monad2 m2) => Functor (WriterT2 w m1 m2) where-    fmap f v = WriterT2 $ (\(a, w) -> (f a, w)) |$>> (runWriterT2 v)-instance (Monoid w, Monad m1, Monad2 m2) => Applicative (WriterT2 w m1 m2) where-    pure a = WriterT2 $ (**:) (a, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2) => Monad (WriterT2 w m1 m2) where  -    return = pure-    (WriterT2 v) >>= f = WriterT2 $-        v >>== \(a, w) ->-        runWriterT2 (f a) >>== \(a', w') ->-        (**:) (a', w <> w')-instance (Monoid w, Monad m1, Monad2 m2) => MonadWriter w (WriterT2 w m1 m2) where-    writer   = WriterT2 . (**:)-    tell w   = writer $ ((), w)-    listen m = WriterT2 $-        runWriterT2 m >>== \(a, w) ->-        (**:) ((a, w), w) -    pass m   = WriterT2 $-        runWriterT2 m >>== \((a, f), w) ->-        (**:) (a, f w)--instance (Monoid w) => MonadTrans2 (WriterT2 w) where-    trans2 m = WriterT2 $ -        m >>== \a ->-        (**:) (a, mempty)-instance (Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (WriterT2 w m1 m2) where-    liftIO = trans2 . (-*) . liftIO--execWriterT2 :: (Monad m1, Monad2 m2) => WriterT2 w m1 m2 a -> m1 (m2 w)-execWriterT2 m =-    runWriterT2 m >>== \(_, w) ->-    (**:) w--mapWriterT2 :: (m1 (m2 (a, w)) -> n1 (n2 (b, w'))) -> WriterT2 w m1 m2 a -> WriterT2 w' n1 n2 b-mapWriterT2 f m = WriterT2 $ f (runWriterT2 m)--------------------------------------------------------------------------- Level-3--newtype WriterT3 w m1 m2 m3 a = WriterT3 { runWriterT3 :: m1 (m2 (m3 (a, w))) }--instance (Monad m1, Monad2 m2, Monad3 m3) => Functor (WriterT3 w m1 m2 m3) where-    fmap f v = WriterT3 $ (\(a, w) -> (f a, w)) |$>>> (runWriterT3 v)-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Applicative (WriterT3 w m1 m2 m3) where-    pure a = WriterT3 $ (***:) (a, mempty)-    (<*>)  = ap-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => Monad (WriterT3 w m1 m2 m3) where  -    return = pure-    (WriterT3 v) >>= f = WriterT3 $-        v >>>== \(a, w) ->-        runWriterT3 (f a) >>>== \(a', w') ->-        (***:) (a', w <> w')-instance (Monoid w, Monad m1, Monad2 m2, Monad3 m3) => MonadWriter w (WriterT3 w m1 m2 m3) where-    writer   = WriterT3 . (***:)-    tell w   = writer $ ((), w)-    listen m = WriterT3 $-        runWriterT3 m >>>== \(a, w) ->-        (***:) ((a, w), w) -    pass m   = WriterT3 $-        runWriterT3 m >>>== \((a, f), w) ->-        (***:) (a, f w)--instance (Monoid w) => MonadTrans3 (WriterT3 w) where-    trans3 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--execWriterT3 :: (Monad m1, Monad2 m2, Monad3 m3) => WriterT3 w m1 m2 m3 a -> m1 (m2 (m3 w))-execWriterT3 m =-    runWriterT3 m >>>== \(_, w) ->-    (***:) w--mapWriterT3 :: (m1 (m2 (m3 (a, w))) -> n1 (n2 (n3 (b, w')))) -> WriterT3 w m1 m2 m3 a -> WriterT3 w' n1 n2 n3 b-mapWriterT3 f m = WriterT3 $ f (runWriterT3 m)--

@@ -1,396 +0,0 @@-{-|-Module      : DeepControl.MonadTrans-Description : Enable deep level Monad-Transform programming.-Copyright   : (c) Andy Gill 2001,-              (c) Oregon Graduate Institute of Science and Technology, 2001,-              (C) 2015 KONISHI Yohsuke -License     : BSD-style (see the file LICENSE)-Maintainer  : ocean0yohsuke@gmail.com-Stability   : experimental-Portability : -----This module enables you to program in Monad-Transformer style for more __deeper__ level than the usual @Control.Monad.Trans@ module expresses.-You would realize exactly what __/more deeper level/__ means by reading the example codes, which are attached on the page bottom.-Note: all the MonadTransx instances for Level-4 and Level-5 haven't been written yet.--}-module DeepControl.MonadTrans (-    -- * MonadIO-    MonadIO(..),--    -- * MonadTrans-    MonadTrans(..), -    MonadTrans2(..),-    MonadTrans3(..),-    MonadTrans4(..),-    MonadTrans5(..),--    -- * Level-1 example-    -- $Example_Level1--    -- * Level-2 example-    -- $Example_Level2--) where--import DeepControl.Monad--import Control.Monad.IO.Class--------------------------------------------------------------------------- Level-1--class  MonadTrans t  where-    -- | Alias for @'Control.Monad.Trans.Class.lift'@.-    trans :: (Monad m) => m a -> t m a--------------------------------------------------------------------------- Level-2--class  MonadTrans2 t  where-    trans2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a--------------------------------------------------------------------------- Level-3--class  MonadTrans3 t  where-    trans3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a--------------------------------------------------------------------------- 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--------------------------------------------------------------------------- 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--------------------------------------------------------------------------- Examples--{- $Example_Level1-Here is a monad transformer example how to implement a tiny interpreter with RWST-ExceptT-IO monad, a level-1 monad-transformation.--Please turn on three pragmas GeneralizedNewtypeDeriving, FlexibleInstances and MultiParamTypeClasses on this example.-->import DeepControl.Applicative->import DeepControl.Monad->import DeepControl.MonadTrans->import DeepControl.Monad.Except->import DeepControl.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)->->-- Value->data Value = IntVal Int          -- Int Value ->           | FunVal Env Name Exp -- Functional Value->           deriving (Show)->->-- Environment->type Env = M.Map Name Value    -- mapping from names to values->->-- ----------------------------------------------->-- Monad-Transform->->type EvalError = String->instance Error EvalError where->    strMsg x = x-> ->newtype Eval a = Eval (RWST Env [String] Int ->                      (ExceptT EvalError->                          IO) a)->  deriving (Functor, Applicative, Monad, MonadIO)->->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->->instance MonadError EvalError Eval where->    throwError = Eval . trans . throwError->    catchError x h = ->        let x' = unEval x->        in Eval $ (liftCatch catchError x') (\e -> unEval (h e))->instance MonadReader Env Eval where->    ask     = Eval $ ask->    local x = Eval . (local x) . unEval->instance MonadWriter [String] Eval where->    writer   = Eval . writer->    listen m = Eval $ (listen (unEval m)) ->    pass m   = Eval $ (pass (unEval m)) ->instance MonadState Int Eval where->    get   = Eval $ get->    put   = Eval . put->    state = Eval . state->->-- ----------------------------------------------->-- 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"--}--{- $Example_Level2-Here is a monad transformer example how to implement Polish Notation with StateT2-IO-Maybe monad, a level-2 monad-transformation.-->import DeepControl.Applicative->import DeepControl.Commutative (cmap)->import DeepControl.Monad->import DeepControl.Monad.State->import DeepControl.MonadTrans->->------------------------------------------------>-- 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->poland_calc xs = evalState (cmap poland xs >> pop) []->->-- > 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->->pushT :: a -> StateT [a] Maybe a->pushT x = do ->    xs <- get->    put (x:xs)->    return x->->popT :: StateT [a] Maybe a->popT = 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])->->polandT :: String -> StateT [Double] Maybe Double->polandT "+" = do ->    x <- popT->    y <- popT->    pushT (y + x)->polandT "-" = do ->    x <- popT->    y <- popT->    pushT (y - x)->polandT "*" = do ->    x <- popT->    y <- popT->    pushT (y * x)->polandT "/" = do->    x <- popT->    y <- popT->    trans $ guard (x /= 0)->    pushT (y / x)->polandT x = pushT (read x :: Double)->->poland_calcT :: [String] -> Maybe Double->poland_calcT xs = evalStateT (cmap polandT xs >> popT) []->->-- > poland_calcT ["1","2","*"]->-- Just 2.0->-- > poland_calcT ["1","2","-"]->-- Just (-1.0)->-- > poland_calcT ["1","2","+","3","*"]->-- Just 9.0->-- > poland_calcT ["1","2","+","3","*","3","/"]->-- Just 3.0->-- > poland_calcT ["1","2","+","3","*","0","/"]->-- Nothing->->------------------------------------------------>-- StateT2-IO-Maybe->->pushT2 :: a -> StateT2 [a] IO Maybe a->pushT2 x = do ->    xs <- get->    put (x:xs)->    return x->popT2 :: StateT2 [a] IO Maybe a->popT2 = do ->    xs <- get->    put (tail xs)->    return (head xs)->->polandT2 :: String -> StateT2 [Double] IO Maybe Double->polandT2 "+" = do ->    x <- popT2->    y <- popT2->    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))->    pushT2 (y + x)->polandT2 "-" = do ->    x <- popT2->    y <- popT2->    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))->    pushT2 (y - x)->polandT2 "*" = do->    x <- popT2->    y <- popT2->    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))->    pushT2 (y * x)->polandT2 "/" = do->    x <- popT2->    y <- popT2->    liftIO $ putStr (show y ++" / "++ show x ++" = ")->    trans2.(*:) $ guard (x /= 0)->    liftIO $ putStr (show (y / x) ++"\n")->    pushT2 (y / x)->polandT2 x = pushT2 (read x :: Double)->->poland_calcT2 :: [String] -> IO (Maybe Double)->poland_calcT2 xs = evalStateT2 (cmap polandT2 xs >> popT2) []->->-- > poland_calcT2 ["1","2","*"]->-- 1.0 * 2.0 = 2.0->-- Just 2.0->-- > poland_calcT2 ["1","2","+","3","*"]->-- 1.0 + 2.0 = 3.0->-- 3.0 * 3.0 = 9.0->-- Just 9.0->-- > poland_calcT2 ["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_calcT2 ["1","2","+","3","*","0","/"]->-- 1.0 + 2.0 = 3.0->-- 3.0 * 3.0 = 9.0->-- 9.0 / 0.0 = Nothing--}

@@ -4,7 +4,7 @@  ## Installing with [Stack](https://github.com/commercialhaskell/stack/blob/master/doc/GUIDE.md) -If you haven't installed Stack yet, install [Stack](https://github.com/commercialhaskell/stack#readme). +If you haven't installed Stack yet, install [Stack](https://github.com/commercialhaskell/stack#readme).  If you have never even used Stack, launch the terminal and go to your working directory: @@ -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.1.0.0` to your extra-deps field in stack.yaml too:+Add `deepcontrol-0.3.0.0` to your extra-deps field in stack.yaml too:  stack.yaml:      extra-deps:     ...-    - deepcontrol-0.1.0.0+    - deepcontrol-0.3.0.0  And type as below: @@ -77,7 +77,7 @@ Stack must fetch and install `deepcontrol` automatically.      ../yourproject$ stack build-    deepcontrol-0.1.0.0: configure+    deepcontrol-0.3.0.0: configure     ...  Now start ghci and see if it works well.@@ -109,7 +109,7 @@     .../yourproject$ cabal install deepcontrol     Resolving dependencies...     ...-    + Now start ghci and see if it works well.      .../yourproject$ cabal repl@@ -119,9 +119,9 @@  ## Examples -### [Applicative](https://hackage.haskell.org/package/deepcontrol-0.1.0.0/docs/DeepControl-Applicative.html)+### [Applicative](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Applicative.html) -This module enables you to program in applicative style for more deeper level than the usual Applicative module expresses. +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.      Prelude> :m DeepControl.Applicative@@ -130,12 +130,12 @@  bra-ket notation: -    > (1+) |> 2 +    > (1+) |> 2     3-    > 1 <| (+2) +    > 1 <| (+2)     3 -    > 1 <|(+)|> 2 +    > 1 <|(+)|> 2     3     > 1 <|(+)|> 2 <|(*)|> 3     9@@ -147,10 +147,10 @@  bra-ket notation: -    > (1+) |$> [2] +    > (1+) |$> [2]     [3]-    > [1] <$| (+2) -    [3] +    > [1] <$| (+2)+    [3]     > ("<"++)|$> ["a","b"] <$|(++">")     ["<a>","<b>"] @@ -158,39 +158,39 @@     [3]      > [1] <$|(+)|*> [2]-    [3] -    > [1] <$|(+)|*> [0,1,2] +    [3]+    > [1] <$|(+)|*> [0,1,2]     [1,2,3]     > [0,1] <$|(+)|*> [2,3] <$|(+)|*> [4,5]     [6,7,7,8,7,8,8,9] -    > foldr (\x acc -> x <$|(:)|*> acc) ((*:) []) [Just 1, Just 2,  Just 3] +    > 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 (even <$|(&&)|*> (10 >)) [1..100] +    > filter (even <$|(&&)|*> (10 >)) [1..100]     [2,4,6,8]-    > filter (even <$|(&&)|*> (10 >) <$|(&&)|*> (5 <)) [1..100] +    > filter (even <$|(&&)|*> (10 >) <$|(&&)|*> (5 <)) [1..100]     [6,8]  braket-cover notation -    > [(1+)] |* 2 -    [3] -    > [1] <$|(+)|* 2 +    > [(1+)] |* 2     [3]-    > [1] <$|(+)|* 2 <$|(*)|* 3 +    > [1] <$|(+)|* 2+    [3]+    > [1] <$|(+)|* 2 <$|(*)|* 3     [9] -    > Just 1 <$|(,)|* 2 +    > Just 1 <$|(,)|* 2     Just (1,2) -    > 1 *| [(+2)] +    > 1 *| [(+2)]     [3]-    > 1 *| [(+)] |* 2 +    > 1 *| [(+)] |* 2     [3]-    > 1 *|[(+),(-),(*),(^)]|* 2 +    > 1 *|[(+),(-),(*),(^)]|* 2     [3,-1,2,1]      > 1 *|Just (,)|* 2@@ -207,7 +207,7 @@      > [Just 1] <<$|(+)|*>> [Just 2]     [Just 3]-    > [Just 1] <<$|(,)|*>> [Just 2] +    > [Just 1] <<$|(,)|*>> [Just 2]     [Just (1,2)]      > [[1]] <<$|(+)|*>> [[2]] <<$|(-)|*>> [[3]]@@ -222,22 +222,22 @@  braket-cover notation: -    > [Just 1] <<$|(+)|** 2 +    > [Just 1] <<$|(+)|** 2     [Just 3]-    > 1 **|(+)|$>> [Just 2] +    > 1 **|(+)|$>> [Just 2]     [Just 3]-    > 1 **|[Just (+)]|**  2 +    > 1 **|[Just (+)]|**  2     [Just 3]-    > 1 **|[Just (+), Just (-), Just (*), Nothing]|** 2 +    > 1 **|[Just (+), Just (-), Just (*), Nothing]|** 2     [Just 3,Just (-1),Just 2,Nothing] -    > [Just 1] <<$|(+)|-* [2] +    > [Just 1] <<$|(+)|-* [2]     [Just 3]-    > [Just 1] <<$|(+)|*- Just 2 +    > [Just 1] <<$|(+)|*- Just 2     [Just 3]-    >      [1]  -*|(+)|$>> [Just 2] +    >      [1]  -*|(+)|$>> [Just 2]     [Just 3]-    >   Just 1  *-|(+)|$>> [Just 2] +    >   Just 1  *-|(+)|$>> [Just 2]     [Just 3]     >   Just 1  *-|[Just (+)]|** 2     [Just 3]@@ -258,7 +258,7 @@  Not completely written up yet. -### [Monad](https://hackage.haskell.org/package/deepcontrol-0.1.0.0/docs/DeepControl-Monad.html)+### [Monad](https://hackage.haskell.org/package/deepcontrol-0.3.0.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.@@ -270,8 +270,8 @@ import DeepControl.Monad  listlist :: [[String]]             -- List-List Monad-listlist = [["a","b"]] >>== \x -> -           [[0],[1,2]] >>== \y -> +listlist = [["a","b"]] >>== \x ->+           [[0],[1,2]] >>== \y ->            (**:) $ x ++ show y  -- > listlist@@ -281,20 +281,19 @@ ```haskell import DeepControl.Applicative import DeepControl.Monad--isJust (Just _) = True-isJust _        = False+import DeepControl.Monad.Trans.Writer -pythagorean_triples :: [Maybe (Int, Int, Int)]  -- List-Maybe Monad-pythagorean_triples = filter isJust $-    [1..10] >-== \x ->-    [1..10] >-== \y ->-    [1..10] >-== \z ->-    guard (x < y && x*x + y*y == z*z) ->~-    (**:) (x,y,z)+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) --- > pythagorean_triples--- [Just (3,4,5),Just (6,8,10)]+-- > runWriter |$> factorial 5+-- Just (120,[0,1,1,2,6,24]) ```  #### Level-3@@ -302,28 +301,68 @@ ```haskell import DeepControl.Applicative import DeepControl.Monad--isJust (Just _) = True-isJust _        = False+import DeepControl.Monad.Trans.Writer -pythagorean_triples :: IO [Maybe (Int, Int, Int)]  -- IO-List-Maybe Monad-pythagorean_triples = filter isJust |$> (-    [1..10] ->-== \x ->-    [1..10] ->-== \y ->-    [1..10] ->-== \z ->-    guard (x < y && x*x + y*y == z*z) -->~-    print (x,y,z) >--~-    (***:) (x,y,z)-  )+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) --- > pythagorean_triples--- (3,4,5)--- (6,8,10)--- [Just (3,4,5),Just (6,8,10)]+-- > runWriter |$>> factorial+-- 0+-- 1+-- 1+-- 2+-- 6+-- 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) -### [Arrow](https://hackage.haskell.org/package/deepcontrol-0.1.0.0/docs/DeepControl-Arrow.html)+#### Level-2 -### [Commutative](https://hackage.haskell.org/package/deepcontrol-0.1.0.0/docs/DeepControl-Commutative.html)+Here is a monad transformer example how to implement Ackermann function, improved to stop within a certain limit of time, with ReaderT2-IO-Maybe monad, a level-2 monad-transformation. +```haskell+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(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++-- λ> commute $ calc_ackermann 1000 |$> [0..4] |* 4+-- [Just 5,Just 6,Just 11,Just 125,Nothing]+```++### [Monad-Morph](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Monad-Morph.html)++### [Commutative](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Commutative.html)++### [Arrow](https://hackage.haskell.org/package/deepcontrol-0.3.0.0/docs/DeepControl-Arrow.html)

@@ -1,5 +1,5 @@ name:                deepcontrol-version:             0.2.0.0+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. license:             BSD3@@ -25,24 +25,28 @@                      , DeepControl.Applicative                      , DeepControl.Commutative                      , DeepControl.Monad-                     , DeepControl.Monad.Except-                     , DeepControl.Monad.List-                     , DeepControl.Monad.Maybe-                     , DeepControl.Monad.RWS-                     , DeepControl.Monad.Reader-                     , DeepControl.Monad.State-                     , DeepControl.Monad.Writer-                     , DeepControl.MonadTrans+                     , DeepControl.Monad.Morph+                     , DeepControl.Monad.Trans+                     , DeepControl.Monad.Trans.RWS+                     , DeepControl.Monad.Trans.Reader+                     , DeepControl.Monad.Trans.State+                     , DeepControl.Monad.Trans.Writer   -- other-modules:       -  -- other-extensions:    -  build-depends:       base >=4.8 && <4.9-                     , mtl >=2.2 && <2.3-                     , transformers+  other-extensions:    MultiParamTypeClasses+                     , FlexibleInstances+                     , UndecidableInstances+                     , DeriveFunctor+                     , GeneralizedNewtypeDeriving+                     , FunctionalDependencies+  build-depends:       base >=4.8 && <5+                     , mtl >=2.2+                     , mmorph >= 1.0+                     , transformers >=0.4   --hs-source-dirs:         default-language:    Haskell2010   --Ghc-Options:         -Wall -O2 -Test-Suite doctest+Test-Suite doctests   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   HS-Source-Dirs:       test@@ -61,6 +65,15 @@   Build-Depends:        base                       , HUnit >= 1.3.0                       , deepcontrol+Test-Suite UnitTest_Commutative+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  -- Ghc-Options:          -threaded -Wall+  Main-Is:              UnitTest_Commutative.hs+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , deepcontrol Test-Suite UnitTest_Monad   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010@@ -69,5 +82,57 @@   Main-Is:              UnitTest_Monad.hs   Build-Depends:        base                       , HUnit >= 1.3.0+                      , deepcontrol+                      , mtl+                      , safe+Test-Suite UnitTest_Monad-Level1+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  -- Ghc-Options:          -threaded -Wall+  Main-Is:              UnitTest_Monad-Level1.hs+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , mtl, containers+                      , deepcontrol+Test-Suite UnitTest_Monad-Level2+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  -- Ghc-Options:          -threaded -Wall+  Main-Is:              UnitTest_Monad-Level2.hs+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , mtl, transformers+                      , deepcontrol+Test-Suite UnitTest_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+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , mtl, transformers+                      , deepcontrol+Test-Suite UnitTest_MonadMorph+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  -- Ghc-Options:          -threaded -Wall+  Main-Is:              UnitTest_MonadMorph.hs+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , mtl+                      , deepcontrol+Test-Suite UnitTest_MonadMorph-Level1+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  -- Ghc-Options:          -threaded -Wall+  Main-Is:              UnitTest_MonadMorph-Level1.hs+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , mtl                       , deepcontrol 

@@ -1,4 +1,3 @@-module Main where import Test.HUnit  import DeepControl.Applicative

@@ -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,51 @@+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]+    ]+++

@@ -0,0 +1,345 @@+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,12 +1,14 @@-module Main where import Test.HUnit  import DeepControl.Applicative import DeepControl.Monad+import DeepControl.Monad.Trans.Writer+import DeepControl.Monad.Trans.Reader -import DeepControl.Monad.Writer-import DeepControl.Monad.Reader+import Control.Monad.Identity +import Safe+ main :: IO () main = do     runTestTT $ TestList [@@ -14,13 +16,14 @@         , TestList tLevel2         , TestList tLevel3         ]+    runTestTT tests_Level0     runTestTT tests_Level2     runTestTT tests_Level3     return ()  tLevel0 = ("Level0" ~:) |$>-    [ (3 >- Just)    ~?= (Just 3)-    , (Just -< 3)    ~?= (Just 3)+    [ (3 >- Just)    ~?= Just 3+    , (Just -< 3)    ~?= Just 3      , (1 >- (+1) >- (*2) >- (+3))     ~?= 7     , (1 >- ((+1) >-> (*2) >-> (+3))) ~?= 7@@ -50,30 +53,42 @@     , (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 = [["a","b"]] >>== \x ->+        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 = (Just |$> [1..10]) >>== \x ->-                     (Just |$> [1..10]) >>== \y ->-                     (Just |$> [1..10]) >>== \z -> -                     ((*:) $ guard (x < y && x*x + y*y == z*z)) >>~-                     (**:) (x,y,z)-        filter isJust actual @?= [Just (3,4,5),Just (6,8,10)]-    , "List-Maybe" ~: "(>-==), (->~)" ~: do-        let actual = [1..10] >-== \x ->-                     [1..10] >-== \y ->-                     [1..10] >-== \z -> -                     guard (x < y && x*x + y*y == z*z) ->~-                     (**:) (x,y,z)-        filter isJust actual @?= [Just (3,4,5),Just (6,8,10)]+        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+    , "(->)-Maybe" ~: "(>-==)" ~: do         let lengthM :: [Int] -> Maybe Int             lengthM [] = Nothing             lengthM xs = Just (length xs) @@ -88,7 +103,7 @@         let sumR :: Reader [Int] Int             sumR = sum |$> ask             lengthRM :: Reader [Int] (Maybe Int)-            lengthRM = Reader $ \r -> case r of+            lengthRM = ReaderT $ \r -> Identity $ case r of                                         [] -> Nothing                                         xs -> Just (length xs)              averageRM :: Reader [Int] (Maybe Double)@@ -110,9 +125,6 @@         (runWriter |$> factorial 5) @?= Just (120,[0,1,1,2,6,24])      ]-  where-    isJust (Just _) = True-    isJust _        = False  tests_Level3 :: Test tests_Level3 = test [ 

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

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