packages feed

deepcontrol (empty) → 0.1.0.0

raw patch · 14 files changed

+1575/−0 lines, 14 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, deepcontrol, doctest, mtl

Files

+ DeepControl/Applicative.hs view
@@ -0,0 +1,421 @@+{-|+Module      : DeepControl.Applicative+Description : Enable deep level Applicative style programming.+Copyright   : KONISHI Yohuske 2015+License     : BSD-style (see the LICENSE file in the distribution)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module enables you to program in applicative style for more __deeper__ level than the usual 'Control.Applicative' module expresses.+You would soon realize exactly what __/more deeper level/__ means by reading the example codes in order, which are attached on the functions below.+Note: all braket-cover notation for Level-4 and Level-5 is not written yet.+-}+module DeepControl.Applicative (+    module Control.Applicative,++    -- * Level-0+    -- ** bra-ket notation+    (|>), (<|),++    -- * Level-1+    -- ** cover notation+    (*:),+    -- ** bra-ket notation+    (|$>), (<$|), (|*>), (<*|),+    -- ** braket-cover notation+    (|*), (*|),++    -- * Level-2+    -- ** cover notation+    (**:), (*-), (-*),+    -- ** bra-ket notation+    (|$>>), (<<$|), (|*>>), (<<*|),+    -- ** braket-cover notation+    (|**), (**|), (|-*), (|*-), (-*|), (*-|),++    -- * Level-3+    -- ** cover notation+    (***:), (**-), (*-*), (-**), (--*), (-*-), (*--),+    -- ** bra-ket notation+    (|$>>>), (<<<$|), (|*>>>), (<<<*|),+    -- ** braket-cover notation+    (|***), (***|),+    (|-**), (|*-*), (|**-), (|--*), (|-*-), (|*--),+    (-**|), (*-*|), (**-|), (--*|), (-*-|), (*--|),++    -- * Level-4+    -- ** cover notation+    (****:), +    -- ** bra-ket notation+    (|$>>>>), (<<<<$|), (|*>>>>), (<<<<*|),++    -- * Level-5+    -- ** cover notation+    (*****:), +    -- ** bra-ket notation+    (|$>>>>>), (<<<<<$|), (|*>>>>>), (<<<<<*|),++    ) where ++import Control.Applicative++-- -----------------------------------------------------------------------------+-- Level-0 functions++infixl 4  |>, <|+-- | Alias for @'$'@. +-- +-- >>> (1+) |> 2+-- 3+(|>) :: (a -> b) -> a -> b+(|>) = ($)++-- | The auguments-flipped function for @'|>'@. +-- +-- >>> 1 <| (+2) +-- 3 +-- >>> 1 <|(+)|> 2 +-- 3 +-- >>> 1 <|(+)|> 2 <|(*)|> 3+-- 9+--+-- >>> 1 <|(,)|> 2+-- (1,2)+(<|) :: a -> (a -> b) -> b+(<|) = flip (|>)++-- -----------------------------------------------------------------------------+-- Level-1 functions++infixl 5  *:+-- | Alias for @'pure'@.+(*:) :: (Applicative f) => a -> f a+(*:) = pure++infixl 4 |$>+-- | Alias for @'<$>'@.+--+-- >>> (1+) |$> [2] +-- [3]+(|$>) :: Functor f => (a -> b) -> f a -> f b+(|$>) = (<$>)++infixl 3  <$|, |*>, <*|, |*, *|+-- | The auguments-flipped function for @'|$>'@.+--+-- >>> [1] <$| (+2) +-- [3]+--+-- >>> ("<"++)|$> ["a","b"] <$|(++">")+-- ["<a>","<b>"]+(<$|) :: Functor f => f a -> (a -> b) -> f b+(<$|) = flip (|$>)++-- | Alias for @'<*>'@.+-- +-- >>> [(1+)] |*> [2]+-- [3]+--+-- >>> [1] <$|(+)|*> [2]+-- [3]+-- >>> [1] <$|(+)|*> [0,1,2] +-- [1,2,3]+-- >>> [0,1] <$|(+)|*> [2,3] <$|(^)|*> [4,5]+-- [16,32,81,243,81,243,256,1024]+--+-- >>> 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]+-- [2,4,6,8]+-- >>> filter (even <$|(&&)|*> (10 >) <$|(&&)|*> (5 <)) [1..100]+-- [6,8]+(|*>) :: Applicative f => f (a -> b) -> f a -> f b+(|*>) = (<*>)++-- | The auguments-flipped function for @'|*>'@. +(<*|) :: Applicative f => f a -> f (a -> b) -> f b+(<*|) = flip (|*>)++-- | Combination consisted of ket @'|*>'@ and cover @'*:'@, defined as @f |* x = f |*> ((*:) x)@.+--+-- >>> [(1+)] |* 2+-- [3]+-- >>> [1] <$|(+)|* 2 +-- [3]+-- >>> [1] <$|(+)|* 2 <$|(*)|* 3+-- [9]+--+-- >>> Just 1 <$|(,)|* 2 +-- Just (1,2)+(|*) :: Applicative f => f (a -> b) -> a -> f b+f |* x = f |*> ((*:) x)++-- | The auguments-flipped function for @'|*'@. +--+-- >>> 1 *| [(+2)]+-- [3]+-- >>> 1 *| [(+)] |* 2+-- [3]+-- >>> 1 *|[(+),(-),(*),(^)]|* 2+-- [3,-1,2,1]+-- +-- >>> 1 *|Just (,)|* 2+-- Just (1,2)+--+(*|) :: Applicative f => a -> f (a -> b) -> f b+(*|) = flip (|*)++-- -----------------------------------------------------------------------------+-- Level-2 functions++infixl 5  **:+infixl 5  -*, *-+-- | Combination consisted of cover @'*:'@ twice, defined as @(**:) = (*:) . (*:)@.+(**:) :: (Applicative f1, Applicative f2) => a -> f1 (f2 a)+(**:) = (*:) . (*:)++-- | Combination consisted of cover @'*:'@ and ket @'|$>'@, defined as @(-*) = ((*:)|$>)@.+(-*) :: (Applicative f1, Applicative f2) => f1 a -> f1 (f2 a)+(-*) = ((*:)|$>) ++(*-) :: (Applicative f1, Applicative f2) => f2 a -> f1 (f2 a)+-- | Alias for @'*:'@. +(*-) = (*:)++infixl 4  |$>>+-- | Combination consisted of cover @'|$>'@ twice, defined as @(|$>>) = (|$>) . (|$>)@.+--+-- >>> (+1) |$>> [[2]]+-- [[3]]+(|$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)+(|$>>) = (|$>) . (|$>)++infixl 3  <<$|, |*>>, <<*|+infixl 3  |**, **|+infixl 3  |-*, |*-, -*|, *-|+-- | The auguments-flipped function for @'|$>>'@+--+-- >>> [[2]] <<$| (+1)+-- [[3]]+(<<$|) :: (Functor f1, Functor f2) => f1 (f2 a) -> (a -> b) -> f1 (f2 b)+(<<$|) = flip (|$>>)++-- | The lifted function of @'|*>'@, defined as @(|*>>) = liftA2 (|*>)@.+--+-- >>> [Just 1] <<$|(+)|*>> [Just 2] +-- [Just 3]+--+-- >>> [Just 1] <<$|(,)|*>> [Just 2]+-- [Just (1,2)]+--+-- >>> [[1]] <<$|(+)|*>> [[2]] <<$|(-)|*>> [[3]]+-- [[0]]+--+-- >>> foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ([Right (Just 1), Right (Just 2), Right (Just 3)]) :: Either () (Maybe Int)+-- Right (Just 6)+-- >>> foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ([Right (Just 1), Right Nothing, Right (Just 3)]) :: Either () (Maybe Int)+-- Right Nothing+-- >>> foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ([Right (Just 1), Right Nothing, Left ()])+-- Left ()+(|*>>) :: (Applicative f1, Applicative f2) => f1 (f2 (a -> b)) -> f1 (f2 a) -> f1 (f2 b)+(|*>>) = liftA2 (|*>)++-- | The auguments-flipped function for @'|*>>'@.+(<<*|) :: (Applicative f1, Applicative f2) => f1 (f2 a) -> f1 (f2 (a -> b)) -> f1 (f2 b)+(<<*|) = flip (|*>>)++-- | Combination consisted of ket @'|*>>'@ and cover @'**:'@, defined as @f |** x = f |*>> ((**:) x)@.+--+-- >>> [Just 1] <<$|(+)|** 2+-- [Just 3]+(|**) :: (Applicative f1, Applicative f2) => f1 (f2 (a -> b)) -> a -> f1 (f2 b)+f |** x = f |*>> ((**:) x)++-- | The auguments-flipped function for @'|**'@.+--+-- >>> 1 **|(+)|$>> [Just 2]+-- [Just 3]+--+-- >>> 1 **|[Just (+)]|**  2+-- [Just 3]+-- >>> 1 **|[Just (+), Just (-), Just (*), Nothing]|** 2+-- [Just 3,Just (-1),Just 2,Nothing]+(**|) :: (Applicative f1, Applicative f2) => a -> f1 (f2 (a -> b)) -> f1 (f2 b)+(**|)  = flip (|**)++-- | Combination consisted of ket @'|*>>'@ and cover @'-*'@, defined as @f |-* x = f |*>> ((-*) x)@.+--+-- >>> [Just 1] <<$|(+)|-* [2]+-- [Just 3]+(|-*) :: (Applicative f1, Applicative f2) => f1 (f2 (a -> b)) -> f1 a -> f1 (f2 b)+f |-* x = f |*>> ((-*) x)++-- | Combination consisted of ket @'|*>>'@ and cover @'*-'@, defined as @f |-* x = f |*>> ((*-) x)@.+--+-- >>> [Just 1] <<$|(+)|*- Just 2 +-- [Just 3]+(|*-) :: (Applicative f1, Applicative f2) => f1 (f2 (a -> b)) -> f2 a -> f1 (f2 b)+f |*- x = f |*>> ((*-) x)++-- | The auguments-flipped function for @'|-*'@.+--+-- >>> [1] -*|(+)|$>> [Just 2]+-- [Just 3]+(-*|) :: (Applicative f1, Applicative f2) => f1 a -> f1 (f2 (a -> b)) -> f1 (f2 b)+(-*|) = flip (|-*)+-- | The auguments-flipped function for @'|*-'@.+--+-- >>> Just 1 *-|(+)|$>> [Just 2]+-- [Just 3]+-- >>> Just 1 *-|[Just (+)]|** 2+-- [Just 3]+-- >>> Just 1 *-|[Just (+)]|*- Just 2+-- [Just 3]+-- >>> [1] -*|[Just (+)]|*- Just 2+-- [Just 3]+-- >>> [1] -*|[Just (+), Just (-), Just (*), Nothing]|*- Just 2+-- [Just 3,Just (-1),Just 2,Nothing]+-- >>> [0,1] -*|[Just (+), Just (-), Just (*), Nothing]|*- Just 2+-- [Just 2,Just 3,Just (-2),Just (-1),Just 0,Just 2,Nothing,Nothing]+(*-|) :: (Applicative f1, Applicative f2) => f2 a -> f1 (f2 (a -> b)) -> f1 (f2 b)+(*-|) = flip (|*-)++{-+infixl 3  <<*, *>>+(*>>) :: (Applicative f1, Applicative f2) => f1 (f2 a) -> f1 (f2 b) -> f1 (f2 b)+(*>>) = liftA2 (*>)+(<<*) :: (Applicative f1, Applicative f2) => f1 (f2 a) -> f1 (f2 b) -> f1 (f2 a)+(<<*) = liftA2 (<*)+-}++-- -----------------------------------------------------------------------------+-- Level-3 functions++infixl 5  ***:+infixl 5  -**, *-*, **-, --*, -*-, *--+(***:) :: (Applicative f1, Applicative f2, Applicative f3) => a -> f1 (f2 (f3 a))+(***:) = (*:) . (**:)+(-**) :: (Applicative f1, Applicative f2, Applicative f3) => f1 a -> f1 (f2 (f3 a))+(-**) = ((**:)|$>) +(*-*) :: (Applicative f1, Applicative f2, Applicative f3) => f2 a -> f1 (f2 (f3 a))+(*-*) = (*:) . ((*:)|$>) +(**-) :: (Applicative f1, Applicative f2, Applicative f3) => f3 a -> f1 (f2 (f3 a))+(**-) = (**:)+(--*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 a) -> f1 (f2 (f3 a))+(--*) = ((*:)|$>>)+(-*-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f3 a) -> f1 (f2 (f3 a))+(-*-) = ((*:)|$>)+(*--) :: (Applicative f1, Applicative f2, Applicative f3) => f2 (f3 a) -> f1 (f2 (f3 a))+(*--) = (*:)++infixl 4  |$>>>+(|$>>>) :: (Functor f1, Functor f2, Functor f3) => (a -> b) -> f1 (f2 (f3 a)) -> f1 (f2 (f3 b))+(|$>>>) = (|$>) . (|$>>)++infixl 3  <<<$|, |*>>>, <<<*|+infixl 3  |***, ***|+infixl 3  |-**, |*-*, |**-, |--*, |-*-, |*--+infixl 3  -**|, *-*|, **-|, --*|, -*-|, *--|+(<<<$|) :: (Functor f1, Functor f2, Functor f3) => f1 (f2 (f3 a)) -> (a -> b) -> f1 (f2 (f3 b))+(<<<$|) = flip (|$>>>)+(|*>>>) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 a)) -> f1 (f2 (f3 b))+(|*>>>) = liftA2 (|*>>)+(<<<*|) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 a)) -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(<<<*|) = flip (|*>>>)++(|***) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> a -> f1 (f2 (f3 b))+f |*** x = f |*>>> ((***:) x)+(***|) :: (Applicative f1, Applicative f2, Applicative f3) => a -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(***|)  = flip (|***)++(|-**) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f1 a -> f1 (f2 (f3 b))+f |-** x = f |*>>> ((-**) x)+(|*-*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f2 a -> f1 (f2 (f3 b))+f |*-* x = f |*>>> ((*-*) x)+(|**-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f3 a -> f1 (f2 (f3 b))+f |**- x = f |*>>> ((**-) x)+(|--*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f1 (f2 a) -> f1 (f2 (f3 b))+f |--* x = f |*>>> ((--*) x)+(|*--) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f2 (f3 a) -> f1 (f2 (f3 b))+f |*-- x = f |*>>> ((*--) x)+(|-*-) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 (a -> b))) -> f1 (f3 a) -> f1 (f2 (f3 b))+f |-*- x = f |*>>> ((-*-) x)++(-**|) :: (Applicative f1, Applicative f2, Applicative f3) => f1 a -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(-**|) = flip (|-**)+(*-*|) :: (Applicative f1, Applicative f2, Applicative f3) => f2 a -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(*-*|) = flip (|*-*)+(**-|) :: (Applicative f1, Applicative f2, Applicative f3) => f3 a -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(**-|) = flip (|**-)+(--*|) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 a) -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(--*|) = flip (|--*)+(*--|) :: (Applicative f1, Applicative f2, Applicative f3) => f2 (f3 a) -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(*--|) = flip (|*--)+(-*-|) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f3 a) -> f1 (f2 (f3 (a -> b))) -> f1 (f2 (f3 b))+(-*-|) = flip (|-*-)++{-+infixl 3  <<<*, *>>>+(*>>>) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 a)) -> f1 (f2 (f3 b)) -> f1 (f2 (f3 b))+(*>>>) = liftA2 (*>>)+(<<<*) :: (Applicative f1, Applicative f2, Applicative f3) => f1 (f2 (f3 a)) -> f1 (f2 (f3 b)) -> f1 (f2 (f3 a))+(<<<*) = liftA2 (<<*)+-}++-- -----------------------------------------------------------------------------+-- Level-4 functions++infixl 5  ****:+(****:) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => a -> f1 (f2 (f3 (f4 a)))+(****:) = (***:) . (*:)++infixl 4  |$>>>>+(|$>>>>) :: (Functor f1, Functor f2, Functor f3, Functor f4) => (a -> b) -> f1 (f2 (f3 (f4 a))) -> f1 (f2 (f3 (f4 b)))+(|$>>>>) = (|$>) . (|$>>>)++infixl 3  <<<<$|, |*>>>>, <<<<*|+(<<<<$|) :: (Functor f1, Functor f2, Functor f3, Functor f4) => f1 (f2 (f3 (f4 a))) -> (a -> b) -> f1 (f2 (f3 (f4 b)))+(<<<<$|) = flip (|$>>>>)+(|*>>>>) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 (f2 (f3 (f4 (a -> b)))) -> f1 (f2 (f3 (f4 a))) -> f1 (f2 (f3 (f4 b)))+(|*>>>>) = liftA2 (|*>>>)+(<<<<*|) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 (f2 (f3 (f4 a))) -> f1 (f2 (f3 (f4 (a -> b)))) -> f1 (f2 (f3 (f4 b)))+(<<<<*|) = flip (|*>>>>)++{-+infixl 3  <<<<*, *>>>>+(*>>>>) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 (f2 (f3 (f4 a))) -> f1 (f2 (f3 (f4 b))) -> f1 (f2 (f3 (f4 b)))+(*>>>>) = liftA2 (*>>>)+(<<<<*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4) => f1 (f2 (f3 (f4 a))) -> f1 (f2 (f3 (f4 b))) -> f1 (f2 (f3 (f4 a)))+(<<<<*) = liftA2 (<<<*)+-}++-- -----------------------------------------------------------------------------+-- Level-5 functions++infixl 5  *****:+(*****:) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => a -> f1 (f2 (f3 (f4 (f5 a))))+(*****:) = (*:) . (****:)++infixl 4  |$>>>>>+(|$>>>>>) :: (Functor f1, Functor f2, Functor f3, Functor f4, Functor f5) => (a -> b) -> f1 (f2 (f3 (f4 (f5 a)))) -> f1 (f2 (f3 (f4 (f5 b))))+(|$>>>>>) = (|$>) . (|$>>>>)++infixl 3  <<<<<$|, |*>>>>>, <<<<<*|+(<<<<<$|) :: (Functor f1, Functor f2, Functor f3, Functor f4, Functor f5) => f1 (f2 (f3 (f4 (f5 a)))) -> (a -> b) -> f1 (f2 (f3 (f4 (f5 b))))+(<<<<<$|) = flip (|$>>>>>)+(|*>>>>>) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => f1 (f2 (f3 (f4 (f5 (a -> b))))) -> f1 (f2 (f3 (f4 (f5 a)))) -> f1 (f2 (f3 (f4 (f5 b))))+(|*>>>>>) = liftA2 (|*>>>>)+(<<<<<*|) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => f1 (f2 (f3 (f4 (f5 a)))) -> f1 (f2 (f3 (f4 (f5 (a -> b))))) -> f1 (f2 (f3 (f4 (f5 b))))+(<<<<<*|) = flip (|*>>>>>)++{-+infixl 3  <<<<<*, *>>>>>+(*>>>>>) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => f1 (f2 (f3 (f4 (f5 a)))) -> f1 (f2 (f3 (f4 (f5 b)))) -> f1 (f2 (f3 (f4 (f5 b))))+(*>>>>>) = liftA2 (*>>>>)+(<<<<<*) :: (Applicative f1, Applicative f2, Applicative f3, Applicative f4, Applicative f5) => f1 (f2 (f3 (f4 (f5 a)))) -> f1 (f2 (f3 (f4 (f5 b)))) -> f1 (f2 (f3 (f4 (f5 a))))+(<<<<<*) = liftA2 (<<<<*)+-}
+ DeepControl/Arrow.hs view
@@ -0,0 +1,84 @@+{-|+Module      : DeepControl.Commutative+Description : Enable deep level Arrow programming.+Copyright   : KONISHI Yohuske 2015,+License     : BSD-style (see the LICENSE file in the distribution)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++-}+{-# LANGUAGE Arrows #-}+module DeepControl.Arrow (+    module Control.Arrow,+    +    Kleisli2(..),+    Kleisli3(..),+    Kleisli4(..),+    Kleisli5(..),++    ) where ++import DeepControl.Applicative+import DeepControl.Monad+import Control.Arrow+import Prelude hiding (id, (.))+import Control.Category++----------------------------------------------------------------------+-- Kleisli2++newtype Kleisli2 m1 m2 a b = Kleisli2 { runKleisli2 :: a -> m1 (m2 b) }++instance (Applicative m1, Monad m1, Monad2 m2) => Category (Kleisli2 m1 m2) where+    id = Kleisli2 $ (**:) +    (Kleisli2 g) . (Kleisli2 f) = Kleisli2 $ f >==> g++instance (Applicative m1, Monad m1, Monad2 m2) => Arrow (Kleisli2 m1 m2) where+    arr f = Kleisli2 $ (**:) . f+    first (Kleisli2 f) = Kleisli2 $ \ ~(b,d) -> f b >>== \c -> (**:) (c,d)+    second (Kleisli2 f) = Kleisli2 $ \ ~(d,b) -> f b >>== \c -> (**:) (d,c)++----------------------------------------------------------------------+-- Kleisli3++newtype Kleisli3 m1 m2 m3 a b = Kleisli3 { runKleisli3 :: a -> m1 (m2 (m3 b)) }++instance (Applicative m1, Monad m1, Monad2 m2, Monad3 m3) => Category (Kleisli3 m1 m2 m3) where+    id = Kleisli3 $ (***:) +    (Kleisli3 g) . (Kleisli3 f) = Kleisli3 $ f >===> g++instance (Applicative m1, Monad m1, Monad2 m2, Monad3 m3) => Arrow (Kleisli3 m1 m2 m3) where+    arr f = Kleisli3 $ (***:) . f+    first (Kleisli3 f) = Kleisli3 $ \ ~(b,d) -> f b >>>== \c -> (***:) (c,d)+    second (Kleisli3 f) = Kleisli3 $ \ ~(d,b) -> f b >>>== \c -> (***:) (d,c)++----------------------------------------------------------------------+-- Kleisli4++newtype Kleisli4 m1 m2 m3 m4 a b = Kleisli4 { runKleisli4 :: a -> m1 (m2 (m3 (m4 b))) }++instance (Applicative m1, Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => Category (Kleisli4 m1 m2 m3 m4) where+    id = Kleisli4 $ (****:) +    (Kleisli4 g) . (Kleisli4 f) = Kleisli4 $ f >====> g++instance (Applicative m1, Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => Arrow (Kleisli4 m1 m2 m3 m4) where+    arr f = Kleisli4 $ (****:) . f+    first (Kleisli4 f) = Kleisli4 $ \ ~(b,d) -> f b >>>>== \c -> (****:) (c,d)+    second (Kleisli4 f) = Kleisli4 $ \ ~(d,b) -> f b >>>>== \c -> (****:) (d,c)++----------------------------------------------------------------------+-- Kleisli5++newtype Kleisli5 m1 m2 m3 m4 m5 a b = Kleisli5 { runKleisli5 :: a -> m1 (m2 (m3 (m4 (m5 b)))) }++instance (Applicative m1, Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => Category (Kleisli5 m1 m2 m3 m4 m5) where+    id = Kleisli5 $ (*****:)+    (Kleisli5 g) . (Kleisli5 f) = Kleisli5 $ f >=====> g++instance (Applicative m1, Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => Arrow (Kleisli5 m1 m2 m3 m4 m5) where+    arr f = Kleisli5 $ (*****:) . f+    first (Kleisli5 f) = Kleisli5 $ \ ~(b,d) -> f b >>>>>== \c -> (*****:) (c,d)+    second (Kleisli5 f) = Kleisli5 $ \ ~(d,b) -> f b >>>>>== \c -> (*****:) (d,c)++
+ DeepControl/Commutative.hs view
@@ -0,0 +1,88 @@+{-|+Module      : DeepControl.Commutative+Description : Commutative Functor, Applicative, Monad.+Copyright   : KONISHI Yohuske 2015,+              Conor McBride and Ross Paterson 2005+License     : BSD-style (see the LICENSE file in the distribution)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module is made of @'Data.Traversable'@, distilling most function names polluted with action kind of concepts into crystalized(static) ones.+Another reason I put this module is for the case if GHC would parse @((->) r)@ as a data constructor someday.++-}+module DeepControl.Commutative (+    -- * The 'Commutative' class+    Commutative(..),+    -- * Utility functions+    commuteMap,+    commuteFor,+    -- * General definitions for superclass methods+    fmapDefault,+    foldMapDefault,+    ) where ++import DeepControl.Applicative++------------------------------------------------------------------------------+-- Commutative++-- | +-- +class (Functor c) => Commutative c where+  -- | This method is the same for @'Data.Traversable.sequenceA'@ just except the name.+  --   The only difference is the name "commute", that is to say from which no action kind of concepts smell.+  commute :: Applicative f => c (f a) -> f (c a)++-- | Do @fmap f@ then commute, the same for @'Data.Traversable.traverse'@.+commuteMap :: (Applicative f, Commutative c) => (a -> f b) -> c a -> f (c b)+commuteMap f = commute . (f |$>)+-- | The auguments-flipped function for @'commuteMap'@, the same for @'Data.Traversable.for'@.+commuteFor :: (Applicative f, Commutative c) => c a -> (a -> f b) -> f (c b)+commuteFor = flip commuteMap++instance Commutative Maybe where+    commute (Just fa) = Just |$> fa+    commute Nothing = (*:) Nothing++instance Commutative [] where+    commute = foldr (\x acc -> x <$|(:)|*> acc) ((*:) [])+  +instance Commutative (Either a) where+    commute (Right x) = Right |$> x+    commute (Left x) = (*:) $ Left x++instance Commutative ((,) a) where+    commute (x, y) = x <|(,)|$> y++instance Commutative (Const m) where+    commute (Const m) = (*:) $ Const m++{-+instance Commutative ((->) r) where+    -- TODO: If GHC could parse this expression, maybe I could write up DeepControl.Monad.+    commute ((r->) mv) = (r->) |$> mv+-}++-- | This function may be used as a value for `fmap` in a `Functor`+--   instance, provided that 'commute' is defined. (Using+--   `fmapDefault` with a `Commutative` instance will result in infinite recursion.)+fmapDefault :: Commutative t => (a -> b) -> t a -> t b+fmapDefault f = getId . commuteMap (Id . f)++-- | This function may be used as a value for `Data.Foldable.foldMap`+--   in a `Foldable` instance.+foldMapDefault :: (Commutative t, Monoid m) => (a -> m) -> t a -> m+foldMapDefault f = getConst . commuteMap (Const . f)++-- local instances+newtype Id a = Id { getId :: a }+instance Functor Id where+    fmap f (Id x) = Id (f x)+instance Applicative Id where+    pure = Id+    Id f <*> Id x = Id (f x)+++
+ DeepControl/Monad.hs view
@@ -0,0 +1,333 @@+{-|+Module      : DeepControl.Monad+Description : Enable deep level Monad programming.+Copyright   : KONISHI Yohuske 2015+License     : BSD-style (see the LICENSE file in the distribution)+Maintainer  : ocean0yohsuke@gmail.com+Stability   : experimental+Portability : ---++This module enables you to program in Monad for more __deeper__ level than the usual 'Control.Monad' module expresses.+You would soon realize exactly what __/more deeper level/__ means by reading the example codes in order, which are attached on the Monadx(Monad2, Monad3, etc) classes below.++Note: ++    * Though this module substitutes for monad-transform consisted of elemental(without-lambda-expression) kind of monad, however, this module is unable to substitute for monad-transform consisted of complicated(tangled-with-lambda-expression) kind of monad at all.+      So this module does not thoroughly make mlt(monad-transformer-library) unnessasary. +      The range in which this module is helpful is confined to the range that single Monad or Monad with Monadx series (namely Monad2, Monad3, etc) defines.+    +    * In my opinion the above problem is hard-wired with the ability of the compiler, that is to say GHC doesn't parse @(r->)@ or @((->) r)@ as a data constructor; +      thus some fundamental expressions such as @(r->)|$>@ or @fmap (r->)@ are useless.+      Theoretically it might be impossible though.++-}+module DeepControl.Monad (+    module Control.Monad,++    -- * Level-0+    -- ** bind function+    (-<), (>-), +    -- ** composite function+    (>->), (<-<),++    -- * Level-1+    -- ** bind-sequence function+    (<<),++    -- * Level-2+    Monad2(..),+    -- ** bind-sequence function+    (>>~), (>-==), (->==), (>-~), (->~),+    -- ** composite function+    (>==>), ++    -- * Level-3+    Monad3(..),+    -- ** bind-sequence function+    (>>-==), (->>==), (>->==) ,(>--==),(->-==), (-->==), +    (>>>~), (->-~), (-->~), (>>-~), (->>~), (>->~), (>--~),+    -- ** composite function+    (>===>),++    -- * Level-4+    Monad4(..),+    -- ** bind-sequence function+    (>>>>~), +    -- ** composite function+    (>====>), ++    -- * Level-5+    Monad5(..),+    -- ** bind-sequence function+    (>>>>>~), +    -- ** composite function+    (>=====>), +    +    ) where ++import DeepControl.Applicative+import Control.Monad++-- -----------------------------------------------------------------------------+-- Level-0 functions++infixl 1  -<, >-+-- | Alias for @'$'@.+--+-- >>> Just -< 3+-- Just 3+(-<) :: (a -> b) -> a -> b+(-<) = ($)+-- | The auguments-flipped function for @'-<'@.+--+-- >>> 3 >- Just+-- Just 3+(>-) :: a -> (a -> b) -> b+(>-) = flip (-<)++infixr 1  <-<, >->+-- | Alias for @'.'@. +--+-- >>> ((3+) <-< (2*) <-< (1+)) -< 1+-- 7+(<-<) :: (b -> c) -> (a -> b) -> a -> c+(<-<) = (.)+-- | The auguments-flipped function for @'<-<'@. +--+-- >>> 1 >- ((+1) >-> (*2) >-> (+3))+-- 7+(>->) :: (a -> b) -> (b -> c) -> a -> c+(>->) = flip (<-<)++-- -----------------------------------------------------------------------------+-- Level-1 functions++infixr 1  <<+-- | The auguments-flipped function for @'>>'@. +(<<) :: Monad m => m b -> m a -> m b +(<<) = flip (>>)++-- -----------------------------------------------------------------------------+-- Level-2 functions++infixr 1  >==>+infixr 1  >>~, >>==+infixr 1  ->==, >-==+infixr 1  ->~, >-~++-- | 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.+-- +-- >>> :{+--  [["a","b"]] >>== \x -> +--  [[0],[1,2]] >>== \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+-- :}+-- [Just (3,4,5),Just (6,8,10)]+-- +-- +class (Monad m2) => Monad2 m2 where+  -- | Bind function of level-2.+  (>>==) :: (Monad m1) => m1 (m2 a) -> (a -> m1 (m2 b)) -> m1 (m2 b)++-- | Composite function of level-2.+(>==>) :: (Monad m1, Monad2 m2) => (a -> m1 (m2 b)) -> (b -> m1 (m2 c)) -> a -> m1 (m2 c)+f >==> g = \x -> f x >>== g+-- | Sequence function of level-2.+(>>~) :: (Monad m1, Monad2 m2) => m1 (m2 a) -> m1 (m2 b) -> m1 (m2 b)+m >>~ k = m >>== \_ -> k+-- | Bind-cover function made of bind @'>>=='@ and cover @'-*'@, defined as @m >-== k = (-*) m >>== k@.+(>-==) :: (Monad m1, Monad2 m2) => m1 a -> (a -> m1 (m2 b)) -> m1 (m2 b)+m >-== k = (-*) m >>== k+-- | Bind-cover function made of bind @'>>=='@ and cover @'*-'@, defined as @m >-== k = (*-) m >>== k@.+(->==) :: (Monad m1, Monad2 m2) => m2 a -> (a -> m1 (m2 b)) -> m1 (m2 b)+m ->== k = (*-) m >>== k+-- | Sequence-cover function made of sequence @'>>~'@ and cover @'-*'@, defined as @m >-~ k = (-*) m >>~ k@.+(>-~) :: (Monad m1, Monad2 m2) => m1 a -> m1 (m2 b) -> m1 (m2 b)+m >-~ k = (-*) m >>~ k+-- | Sequence-cover function made of sequence @'>>~'@ and cover @'*-'@, defined as @m >-~ k = (*-) m >>~ k@.+(->~) :: (Monad m1, Monad2 m2) => m2 a -> m1 (m2 b) -> m1 (m2 b)+m ->~ k = (*-) m >>~ k++instance Monad2 Maybe where+    mmv >>== f = +        mmv >>= \mv ->+        case mv of +            Nothing -> (*:) Nothing+            Just a  -> f a++instance Monad2 [] where+    mmv >>== f = +        mmv >>= \xs -> +        foldr (\x acc -> f x <$|(++)|*> acc) ((*:) []) xs++instance Monad2 (Either e) where+    mmv >>== f = +        mmv >>= \mv -> +        case mv of+            Left l  -> (*:) (Left l)+            Right r -> f r++-- -----------------------------------------------------------------------------+-- Level-3 functions++infixr 1  >===>+infixr 1  >>>~, >>>==+infixr 1  >--==, ->-==, -->==, >>-==, >->==, ->>==+infixr 1  >--~, ->-~, -->~, >>-~, >->~, ->>~++-- | 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+-- :}+-- (3,4,5)+-- (6,8,10)+-- [Just (3,4,5),Just (6,8,10)]+--+class (Monad m3) => Monad3 m3 where+  (>>>==) :: (Monad m1, Monad2 m2) => m1 (m2 (m3 a)) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))++(>===>) :: (Monad m1, Monad2 m2, Monad3 m3) => (a -> m1 (m2 (m3 b))) -> (b -> m1 (m2 (m3 c))) -> a -> m1 (m2 (m3 c))+f >===> g = \x -> f x >>>== g+(>>>~) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))+m >>>~ k = m >>>== \_ -> k+(>--==) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 a -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))+m >--== k = (-**) m >>>== k+(->-==) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 a -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))+m ->-== k = (*-*) m >>>== k+(-->==) :: (Monad m1, Monad2 m2, Monad3 m3) => m3 a -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))+m -->== k = (**-) m >>>== k+(>>-==) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 a) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))+m >>-== k = (--*) m >>>== k+(->>==) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 (m3 a) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))+m ->>== k = (*--) m >>>== k+(>->==) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m3 a) -> (a -> m1 (m2 (m3 b))) -> m1 (m2 (m3 b))+m >->== k = (-*-) m >>>== k+(>--~) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 a -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))+m >--~ k = (-**) m >>>~ k+(->-~) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 a -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))+m ->-~ k = (*-*) m >>>~ k+(-->~) :: (Monad m1, Monad2 m2, Monad3 m3) => m3 a -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))+m -->~ k = (**-) m >>>~ k+(>>-~) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 a) -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))+m >>-~ k = (--*) m >>>~ k+(->>~) :: (Monad m1, Monad2 m2, Monad3 m3) => m2 (m3 a) -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))+m ->>~ k = (*--) m >>>~ k+(>->~) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m3 a) -> m1 (m2 (m3 b)) -> m1 (m2 (m3 b))+m >->~ k = (-*-) m >>>~ k++instance Monad3 Maybe where+    mmmv >>>== f = +        mmmv >>== \mv ->+        case mv of +            Nothing -> (**:) Nothing+            Just a  -> f a++instance Monad3 [] where+    mmmv >>>== f = +        mmmv >>== \xs -> +        foldr (\x acc -> f x <<$|(++)|*>> acc) ((**:) []) xs ++instance Monad3 (Either e) where+    mmmv >>>== f = +        mmmv >>== \mv -> +        case mv of+            Left l  -> (**:) (Left l)+            Right r -> f r++-- -----------------------------------------------------------------------------+-- Level-4 functions++infixr 1  >====>+infixr 1  >>>>~, >>>>==+-- TODO: >>>>~++class (Monad m4) => Monad4 m4 where+  (>>>>==) :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 (m4 a))) -> (a -> m1 (m2 (m3 (m4 b)))) -> m1 (m2 (m3 (m4 b)))++(>====>) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => (a -> m1 (m2 (m3 (m4 b)))) -> (b -> m1 (m2 (m3 (m4 c)))) -> a -> m1 (m2 (m3 (m4 c)))+f >====> g = \x -> f x >>>>== g+(>>>>~) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 a))) -> m1 (m2 (m3 (m4 b))) -> m1 (m2 (m3 (m4 b)))+m >>>>~ k = m >>>>== \_ -> k+++instance Monad4 Maybe where+    mmmmv >>>>== f = +        mmmmv >>>== \mv ->+        case mv of +            Nothing -> (***:) Nothing+            Just a  -> f a++instance Monad4 [] where+    mmmmv >>>>== f = +        mmmmv >>>== \xs -> +        foldr (\x acc -> f x <<<$|(++)|*>>> acc) ((***:) []) xs ++instance Monad4 (Either e) where+    mmmmv >>>>== f = +        mmmmv >>>== \mv -> +        case mv of+            Left l  -> (***:) (Left l)+            Right r -> f r++-- -----------------------------------------------------------------------------+-- Level-5 functions++infixr 1  >=====>+infixr 1  >>>>>~, >>>>>== +-- TODO: >>>>>~++class (Monad m5) => Monad5 m5 where+  (>>>>>==) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 (m5 a)))) -> (a -> m1 (m2 (m3 (m4 (m5 b))))) -> m1 (m2 (m3 (m4 (m5 b))))++(>=====>) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => (a -> m1 (m2 (m3 (m4 (m5 b))))) -> (b -> m1 (m2 (m3 (m4 (m5 c))))) -> a -> m1 (m2 (m3 (m4 (m5 c))))+f >=====> g = \x -> f x >>>>>== g+(>>>>>~) :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => m1 (m2 (m3 (m4 (m5 a)))) -> m1 (m2 (m3 (m4 (m5 b)))) -> m1 (m2 (m3 (m4 (m5 b))))+m >>>>>~ k = m >>>>>== \_ -> k++instance Monad5 Maybe where+    mmmmmv >>>>>== f = +        mmmmmv >>>>== \mv ->+        case mv of +            Nothing -> (****:) Nothing+            Just a  -> f a++instance Monad5 [] where+    mmmmmv >>>>>== f = +        mmmmmv >>>>== \xs -> +        foldr (\x acc -> f x <<<<$|(++)|*>>>> acc) ((****:) []) xs ++instance Monad5 (Either e) where+    mmmmmv >>>>>== f = +        mmmmmv >>>>== \mv -> +        case mv of+            Left l  -> (****:) (Left l)+            Right r -> f r+
+ DeepControl/Monad/RWS.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses, +             FlexibleInstances #-}+module DeepControl.Monad.RWS (+    MonadReader(..), MonadWriter(..), MonadState(..),++    RWS(..), rws, evalRWS, execRWS, ++    ) where ++import DeepControl.Applicative+import DeepControl.Monad++import Control.Monad.Reader (MonadReader(..))+import Control.Monad.Writer (MonadWriter(..))+import Control.Monad.State (MonadState(..))++----------------------------------------------------------------------+-- RWS++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  = (*:)+    m >>= k = RWS $ \r s -> +        runRWS m r s >- \(a, s', w) ->+        runRWS (k a) r s' >- \(b, s'',w') ->+        (b, s'', w `mappend` 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)++
+ DeepControl/Monad/Reader.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE MultiParamTypeClasses, +             FlexibleInstances #-}+module DeepControl.Monad.Reader (+    MonadReader(..),+    asks,++    Reader(..),++    ) where ++import DeepControl.Applicative+import DeepControl.Monad++import Control.Monad.Reader (MonadReader(..))++asks :: MonadReader r m => (r -> a) -> m a+asks = reader++----------------------------------------------------------------------+-- Reader++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 = (*:)+    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++
+ DeepControl/Monad/State.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE MultiParamTypeClasses,+             FlexibleInstances,+             UndecidableInstances #-}+module DeepControl.Monad.State (+    MonadState(..),+    modify, gets,++    State(..), evalState, execState, ++    ) where ++import DeepControl.Applicative+import DeepControl.Monad++import Control.Monad.State (MonadState(..))++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)++----------------------------------------------------------------------+-- State++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'++
+ DeepControl/Monad/Writer.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE MultiParamTypeClasses, +             FlexibleInstances #-}+module DeepControl.Monad.Writer (+    MonadWriter(..),+    listens, censor,++    Writer(..), execWriter,++    ) where ++import DeepControl.Applicative+import DeepControl.Monad++import Control.Monad.Writer (MonadWriter(..))++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)++----------------------------------------------------------------------+-- Writer++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' `mappend` w)++instance (Monoid w) => Monad (Writer w) where+    return   = (*:)+    mv >>= f = +        mv >- \(Writer (a, w)) -> +        (\(Writer (b, w')) -> Writer (b, w `mappend` w')) $ f a+instance (Monoid w) => Monad2 (Writer w) where+    mmv >>== f = +        mmv >>= \(Writer (a, w)) -> +        (\(Writer (b, w')) -> Writer (b, w `mappend` w')) |$> f a+instance (Monoid w) => Monad3 (Writer w) where+    mmv >>>== f = +        mmv >>== \(Writer (a, w)) -> +        (\(Writer (b, w')) -> Writer (b, w `mappend` w')) |$>> f a+instance (Monoid w) => Monad4 (Writer w) where+    mmv >>>>== f = +        mmv >>>== \(Writer (a, w)) -> +        (\(Writer (b, w')) -> Writer (b, w `mappend` w')) |$>>> f a+instance (Monoid w) => Monad5 (Writer w) where+    mmv >>>>>== f = +        mmv >>>>== \(Writer (a, w)) -> +        (\(Writer (b, w')) -> Writer (b, w `mappend` 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++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, KONISHI Yohsuke++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of KONISHI Yohsuke nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ deepcontrol.cabal view
@@ -0,0 +1,60 @@+name:                deepcontrol+version:             0.1.0.0+synopsis:            Enable deeper level style of programming than the usual control provides+description:         This module enables deeper level style of programming than the usual control provides, especially for Applicative and Monad.+license:             BSD3+license-file:        LICENSE+author:              KONISHI Yohsuke+maintainer:          ocean0yohsuke@gmail.com+homepage:            https://github.com/ocean0yohsuke/deepcontrol+copyright:           KONISHI Yohsuke+category:            Control+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     DeepControl.Arrow+                     , DeepControl.Applicative+                     , DeepControl.Commutative+                     , DeepControl.Monad+                     , DeepControl.Monad.RWS+                     , DeepControl.Monad.Reader+                     , DeepControl.Monad.State+                     , DeepControl.Monad.Writer+  -- other-modules:       +  other-extensions:    Arrows+  build-depends:       base >=4.8 && <4.9, mtl >=2.2 && <2.3+  --hs-source-dirs:      +  default-language:    Haskell2010+  Ghc-Options:         -Wall -O2++Test-Suite doctest+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  Ghc-Options:          -threaded -Wall+  Main-Is:              doctests.hs+  Build-Depends:        base+                      , doctest >= 0.9.3+                      , QuickCheck >= 2.8.1++Test-Suite UnitTest_Applicative+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  -- Ghc-Options:          -threaded -Wall+  Main-Is:              UnitTest_Applicative.hs+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , deepcontrol+Test-Suite UnitTest_Monad+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  -- Ghc-Options:          -threaded -Wall+  Main-Is:              UnitTest_Monad.hs+  Build-Depends:        base+                      , HUnit >= 1.3.0+                      , deepcontrol+
+ test/UnitTest_Applicative.hs view
@@ -0,0 +1,179 @@+module Main where+import Test.HUnit++import DeepControl.Applicative++main :: IO ()+main = run >> return ()++-- | Run Unit-Test of this module. +run = runTestTT $ TestList +        [ TestList tLevel0+        , TestList tLevel1+        , TestList tLevel2+        , TestList tLevel3++        ]++----------------------------------------------------------------+-- unit test+----------------------------------------------------------------++tLevel0 = ("Level0" ~:) |$> [ +      TestList $ ("|>" ~:) |$> [ +          (1+) |> 2  ~?= 3+        , (1:) |> [] ~?= [1]+        , ("a"++) |> "b" ~?= "ab"+        , (True &&) |> False ~?= False+        , (True ||) |> False ~?= True+        ]++    , TestList $ ("<|" ~:) |$> [ +          1 <| (+2)  ~?= 3+        , 1 <| (:[]) ~?= [1]+        , "a" <| (++"b")  ~?= "ab"+        , True <| (&& False) ~?= False+        , True <| (|| False) ~?= True+        ]++    , TestList $ ("<| and |>" ~:) |$> [ +          1 <|(+)|> 2               ~?= 3+        , 1 <|(+)|> 2 <|(-)|> 3     ~?= 0+        , 1 <|(+)|> 2 <|(*)|> 3     ~?= 9++        , 1 <|(:)|> []             ~?= [1]+        , 1 <|(:)|> (2 <|(:)|> []) ~?= [1,2]++        , "a" <|(++)|> "b"              ~?= "ab"+        , "a" <|(++)|> "b" <|(++)|> "c" ~?= "abc"++        , True <|(&&)|> False ~?= False+        , True <|(||)|> False ~?= True++        , 1 <|(,)|> 2             ~?= (1,2)+        , 1 <|(,)|> 2 <|(,)|> 3   ~?= ((1,2),3)+        , 1 <|(,)|> (2 <|(,)|> 3) ~?= (1,(2,3))+        ]+    ]++tLevel1 = ("Level1" ~:) |$> [+      (+) |$> [1] |*> [2]      ~?= [3]++    , TestList $ ("|$>" ~:) |$> [ +          (1+) |$> [2] ~?= [3]+        , (1:) |$> [[]] ~?= [[1]]+        , ("a"++) |$> ["b"] ~?= ["ab"]+        , (True &&) |$> [False] ~?= [False]+        , (True ||) |$> [False] ~?= [True]+    +        , (1+) |$> [0,1,2] ~?= [1,2,3]+        , (1+) |$> Just 0  ~?= Just 1+        , (1+) |$> Nothing ~?= Nothing+        , (1+) |$> Right 1  ~?= (Right 2 :: Either () Int)+        , (1+) |$> Left ()  ~?= (Left () :: Either () Int)+        ]+    , TestList $ ("|*>" ~:) |$> [ +          [(1+)] |*> [0,1,2] ~?= [1,2,3]+        , Just (1+) |*> Just 0  ~?= Just 1+        , Just (1+) |*> Nothing ~?= Nothing+        , Right (1+) |*> Right 1 ~?= (Right 2 :: Either () Int)+        , Right (1+) |*> Left () ~?= (Left () :: Either () Int)++        ]+    , TestList $ ("<$|" ~:) |$> [ +          [1] <$| (+2)  ~?= [3]++        , ("("++)|$> ["a","b"] <$|(++")") ~?= ["(a)", "(b)"]+        ]+    , TestList $ ("<$| and |*>" ~:) |$> [ +          [1] <$|(+)|*> [0,1,2] ~?= [1,2,3]+        , Just 1 <$|(+)|*> Just 0  ~?= Just 1+        , Just 1 <$|(+)|*> Nothing ~?= Nothing+        , Right 1 <$|(+)|*> Right 1 ~?= (Right 2 :: Either () Int)+        , Right 1 <$|(+)|*> Left () ~?= (Left () :: Either () Int)++        , [1,11] <$|(+)|*> [0,1,2]              ~?= [1,2,3,11,12,13]+        , [0,1] <$|(+)|*> [2,3] <$|(^)|*> [4,5] ~?= [16,32,81,243,81,243,256,1024]++        , getZipList (ZipList ['a'..'e'] <$|(,)|*> ZipList [1..]) ~?= [('a',1),('b',2),('c',3),('d',4),('e',5)]++        ]+    , TestList $ ("<$|, |*> and higher-order-function" ~:) |$> [ +          foldr (\n acc -> n <$|(+)|*> acc) ((*:) 0) [Just 1, Just 2,  Just 3] ~?= Just 6+        , foldr (\n acc -> n <$|(+)|*> acc) ((*:) 0) [Just 1, Nothing, Just 3] ~?= Nothing++        , foldr (\x acc -> x <$|(:)|*> acc) ((*:) []) [Just 1, Just 2,  Just 3] ~?= Just [1,2,3]+        , foldr (\x acc -> x <$|(:)|*> acc) ((*:) []) [Just 1, Nothing, Just 3] ~?= Nothing++        , filter ((10 >) <$|(&&)|*> even)                  [1..100] ~?= [2,4,6,8]+        , filter ((10 >) <$|(&&)|*> even <$|(&&)|*> (5 <)) [1..100] ~?= [6,8]+        ]+    , TestList $ ("|*, *|" ~:) |$> [ +          [1] <$|(+)|*  2           ~?= [3]+        , 1    *|(+)|$> [2]         ~?= [3]++        , [(1+)] |* 2               ~?= [3]+        , 1 *| [(+2)]               ~?= [3]+        , 1 *| [(+)] |* 2           ~?= [3]++       , [1] <$|(+)|* 2 <$|(-)|* 3 ~?= [0]+       , 1 *|(+)|$> [2] <$|(-)|* 3 ~?= [0]++        , Just 1 <$|(,)|* 2  ~?= Just (1,2)+        , 1 *|Just (,)|* 2 ~?= Just (1,2)+        +        , 1 *|[(+),(-),(*),(^)]|* 2     ~?= [3,-1,2,1]+        ]++   , TestList $ ("other" ~:) |$> [ +          [1] <$|(+)|> 2      ~?= [3]+        --, [2] <*| [1] <$| (+) ~?= [3]  -- invalid form+        , [2] <*|(+)|$> [1]   ~?= [3]+        ]+     ]++tLevel2 = ("Level2" ~:) |$> [+      (+) |$>> [Just 1] |*>> [Just 2]      ~?= [Just 3]++    , TestList $ ("<<$| and |*>>" ~:) |$> [ +          [Just 1] <<$|(+)|*>> [Just 2]              ~?= [Just 3]+        , [[1]] <<$|(+)|*>> [[2]] <<$|(-)|*>> [[3]]  ~?= [[0]]++        , [Just 1] <<$|(,)|*>> [Just 2]              ~?= [Just (1,2)]+        ]+    , TestList $ ("<<$|, |*>> and higher-order-function" ~:) |$> [ +          foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ((Right . Just) |$> [1,2,3])               ~?= (Right (Just 6) :: Either () (Maybe Int))+        , foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) (Right |$> [Just 1,Nothing,Just 3])        ~?= (Right Nothing :: Either () (Maybe Int))+        , foldr (\n acc -> n <<$|(+)|*>> acc) ((**:) 0) ([Right (Just 1), Right Nothing, Left ()]) ~?= (Left () :: Either () (Maybe Int))+        ]+    , TestList $ ("|**, |*-, |-*, **|, *-|, -*|" ~:) |$> [ +          [Just 1] <<$|(+)|** 2          ~?= [Just 3]+        , [Just 1] <<$|(+)|*- Just 2     ~?= [Just 3]+        , [Just 1] <<$|(+)|-* [2]        ~?= [Just 3]+        , 1      **|(+)|$>> [Just 2]     ~?= [Just 3]+        , Just 1 *-|(+)|$>> [Just 2]     ~?= [Just 3]+        , [1]    -*|(+)|$>> [Just 2]     ~?= [Just 3]+        , 1 **|[Just (+)]|** 2        ~?= [Just 3]+        , 1 **|[Just (+), Just (-), Just (*), Nothing]|** 2 ~?= [Just 3,Just (-1),Just 2,Nothing]+        , [0,1] -*|[Just (+), Just (-), Just (*), Nothing]|*- Just 2 ~?= [Just 2,Just 3,Just (-2),Just (-1),Just 0,Just 2,Nothing,Nothing]++        , [[1]] <<$|(+)|** 2 <<$|(-)|** 3    ~?= [[0]]+        , 1 **|(+)|$>> [[2]] <<$|(-)|** 3    ~?= [[0]]+++        ]++    ]++tLevel3 = ("Level3" ~:) |$> [+      (+) |$>>> Right [Just 1] |*>>> Right [Just 2]      ~?= (Right [Just 3] :: Either () [Maybe Int])++    , TestList $ ("<<<$| and |*>>>" ~:) |$> [ +          Right [Just 1] <<<$|(+)|*>>> Right [Just 2]         ~?= (Right [Just 3] :: Either () [Maybe Int])+        , [[[1]]] <<<$|(+)|*>>> [[[2]]] <<<$|(-)|*>>> [[[3]]] ~?= [[[0]]]++        , Right [Just 1] <<<$|(,)|*>>> Right [Just 2]       ~?= (Right [Just (1,2)] :: Either () [Maybe (Int,Int)])+        ]+    ]++
+ test/UnitTest_Monad.hs view
@@ -0,0 +1,130 @@+module Main where+import Test.HUnit++import DeepControl.Applicative+import DeepControl.Monad++import DeepControl.Monad.Writer+import DeepControl.Monad.Reader++main :: IO ()+main = do+    runTestTT $ TestList [+          TestList tLevel0+        , TestList tLevel2+        , TestList tLevel3+        ]+    runTestTT tests_Level2+    runTestTT tests_Level3+    return ()++tLevel0 = ("Level0" ~:) |$>+    [ (3 >- Just)    ~?= (Just 3)+    , (Just -< 3)    ~?= (Just 3)++    , (1 >- (+1) >- (*2) >- (+3))     ~?= 7+    , (1 >- ((+1) >-> (*2) >-> (+3))) ~?= 7+    , (((3+) <-< (2*) <-< (1+)) -< 1) ~?= 7++-- invalid forms+-- ((3+) -< (2*) -< (1+) -< 1)+    ]++tLevel2 = ("Level2" ~:) |$> [+      ([[1]] >>== \x -> [[x]]) ~?= [[1]]+    , ([[1]] >>== \x -> (**:) x) ~?= [[1]]+    , (Just [1] >>== \x -> (**:) x) ~?= Just [1]+    , ([Just 1] >>== \x -> (**:) x) ~?= [Just 1]+    , (Right [1] >>== \x -> (**:) x) ~?= (Right [1] :: Either () [Int])++    , (Right [0] >>== \x -> (**:) (x+1) >>== \x -> (**:) (x+2)) ~?= (Right [3] :: Either () [Int])+    ]++tLevel3 = ("Level3" ~:) |$> [+      ([[[1]]] >>>== \x -> (***:) x) ~?= [[[1]]]+    , ((Just [[1]]) >>>== \x -> (***:) x) ~?= Just [[1]]+    , (([Just [1]]) >>>== \x -> (***:) x) ~?= [Just [1]]+    , (Right (Just [1]) >>>== \x -> (***:) x) ~?= (Right (Just [1]) :: Either () (Maybe [Int]))++    , (Right (Just [0]) >>>== \x -> (***:) (x+1) >>>== \x -> (***:) (x+2)) ~?= (Right (Just [3]) :: Either () (Maybe [Int]))+    , (Right Nothing    >>>== \x -> (***:) (x+1) >>>== \x -> (***:) (x+2)) ~?= (Right Nothing :: Either () (Maybe [Int]))+    ]++tests_Level2 :: Test+tests_Level2 = test [ +      "List-List" ~: "(>>==)" ~: do+        let 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)]++    , "(->)-Maybe" ~: do+        let lengthM :: [Int] -> Maybe Int+            lengthM [] = Nothing+            lengthM xs = Just (length xs) +            averageM :: [Int] -> Maybe Double+            averageM = +                sum >-== \s ->+                lengthM >>== \l ->+                (**:) $ fromIntegral s / fromIntegral l+        averageM [10, 25, 70] @?= Just 35.0+        averageM []           @?= Nothing+    , "Reader-Maybe" ~: do+        let sumR :: Reader [Int] Int+            sumR = sum |$> ask+            lengthRM :: Reader [Int] (Maybe Int)+            lengthRM = Reader $ \r -> case r of+                                        [] -> Nothing+                                        xs -> Just (length xs) +            averageRM :: Reader [Int] (Maybe Double)+            averageRM = +                sumR >-== \s ->+                lengthRM >>== \l ->+                (**:) $ fromIntegral s / fromIntegral l+        runReader averageRM [10, 25, 70] @?= Just 35.0+        runReader averageRM []           @?= Nothing++    , "Maybe-Writer" ~: "(-*)" ~: do+        let factorial :: Int -> Maybe (Writer [Int] Int)+            factorial n | n < 0  = (-*) Nothing+            factorial n | n == 0 = (*:) $ tell [0] >> return 1+            factorial n | n > 0  = +                factorial (n-1) >>== \v ->+                tell [v] ->~+                (**:) (n * v)+        (runWriter |$> factorial 5) @?= Just (120,[0,1,1,2,6,24])++    ]+  where+    isJust (Just _) = True+    isJust _        = False++tests_Level3 :: Test+tests_Level3 = test [ +      "IO-Maybe-Writer" ~: "(>>>==), (-->~), (*-*)" ~: do+        let factorial :: Int -> IO (Maybe (Writer [Int] Int))+            factorial n | n < 0  = (*-*) Nothing+            factorial n | n == 0 = (**:) $ tell [0] >> return 1+            factorial n | n > 0  = +                factorial (n-1) >>>== \v ->+                tell [v] -->~+                (***:) (n * v)+        actual <- factorial 5+        (runWriter |$> actual) @?= Just (120,[0,1,1,2,6,24])+    ]+
+ test/doctests.hs view
@@ -0,0 +1,10 @@+module Main where++import Test.DocTest+--import Test.QuickCheck++main :: IO ()+main = doctest [ "DeepControl/Applicative.hs"+               , "DeepControl/Monad.hs"+               , "DeepControl/Arrow.hs"+               ]