MonadCompose 0.8.4.2 → 0.9.0.0

raw patch · 7 files changed

+191/−730 lines, 7 filesdep +freedep −data-defaultdep −ghc-primdep −kan-extensionsPVP ok

version bump matches the API change (PVP)

Dependencies added: free

Dependencies removed: data-default, ghc-prim, kan-extensions, monad-products, parallel, random, transformers-compat

API changes (from Hackage documentation)

Files

• Control/Linear.hs +0/−405
• Control/Monad/Coproducts3.hs +128/−0
• Control/Monad/EtaInverse.hs +54/−0
• Control/Monad/IOT.hs +0/−114
• Control/Monad/Lifter.hs +2/−2
• Control/Monad/PlusMonad.hs +0/−202
• MonadCompose.cabal +7/−7

@@ -1,405 +0,0 @@-{-# LANGUAGE Trustworthy, Rank2Types, ScopedTypeVariables, MagicHash, UnboxedTuples, FlexibleInstances, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}
--- | A linear type-based I/O system a la Clean - including a "safe C" (like Cyclone).
---
---   This is an alternative to composing monads - one can decompose them into their
---   corresponding comonads, with linear operations for manipulating them.
---   (See Kieburtz, http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.46.5169&rep=rep1&type=pdf)
-module Control.Linear (St, A, Blank, Pair, Fn, (>>==), rtn,
--- * Algebraic operations
-run, bimap, assoc1, assoc2, drop1, drop2, undrop1, undrop2, swap, apply, curry, distr, assoc3, assoc4, void', bimap',
--- * Basic I/O system
-Exclusive, Semiclosed, Open, Placeholder(Placeholder), open, getStdin, getStdout, getStderr, close, close1, fileSize, setFileSize, eof, seek, tell, char, line, lookahead, contents, putC, putS, random,
--- * Safe pointer facilities
-Pointer, Linear(Linear), Nonlinear(Nonlinear), Focused(Focused), Fix(In), fixInj1, fixInj2, Weakening(weakening), contraction, new, free, split, ptrSwap,
--- ** Focusing
-focus, focusHdl,
--- ** Strong update
-peek', poke', changeType,
--- ** Operations on nonlinear data / Weak update
-newNonlinear, peek1, poke1,
--- * Multithreading
-fork, join',
--- * Example programs
-helloWorld, printStuff, concurrent
-) where
-
-import Control.Arrow
-import Control.Category
-import Control.Monad
-import Control.Parallel
-import GHC.Prim
-import GHC.IO
-import GHC.Base (realWorld#)
-import System.IO
-import Foreign.ForeignPtr hiding (unsafeForeignPtrToPtr)
-import Foreign.ForeignPtr.Unsafe
-import Foreign.StablePtr
-import Foreign.Ptr
-import qualified Foreign.Marshal.Alloc as A
-import Foreign.Storable
-import Data.Default
-import Data.Int
-import Prelude hiding (id, (.), curry)
-import System.Random hiding (split, random)
-import System.IO.Unsafe
-
--- * Linear type machinery
-
--- | Values representing the real world.
-data St = St (State# RealWorld)
-
--- | Linear computations are arrows over linear data, but monads over nonlinear data.
-newtype A t u v = A (u -> (v, t))
-
-type Fn t u = A () (Pair t St) (Pair u St)
-
-data Blank = Blank
-
-data Pair t u = Pair t u
-
-instance (Default a) => Category (A a) where
-	id = rtn def
-	a . a2 = a2 >>== \(_ :: a) -> a
-
-instance (Default a) => Arrow (A a) where
-	arr f = A (\x -> (f x, def))
-	first (A f) = A (\(x, y) -> let (z, a) = f x in ((z, y), a))
-
-instance (Default a) => ArrowChoice (A a) where
-	A f +++ A g = A (\ei -> either (\x -> let (y, z) = f x in (Left y, z))
-		(\x -> let (y, z) = g x in (Right y, z))
-		ei)
-	left a = a +++ id
-
-infixl 1 >>==
-
--- | Monadic bind (for nonlinear data).
-{-# INLINE[0] (>>==) #-}
-A f >>== g = A (\x -> case f x of
-	(y, z) -> case g z of
-		A h -> h y)
-
--- | Monadic return
-{-# INLINE[0] rtn #-}
-rtn x = A (\y -> (y, x))
-
--- | This setup is from http://cs.ioc.ee/~tarmo/tsem11/jeltsch1602-slides.pdf
---
--- It implements some of http://pauillac.inria.fr/~fpottier/slides/fpottier-2007-05-linear-bestiary.pdf
-
-{-# INLINE[0] run #-}
-run :: A a St St -> IO a
-run (A f) = IO $ \world -> case f (St world) of (St world', x) -> (# world', x #)
-
-{-# INLINE[0] bimap #-}
-bimap (A f) (A g) = A (\(Pair a b) -> let
-	(c, d) = f a
-	(e, h) = g b in
-	(c `par` e) `seq` (Pair c e, (d, h)))
-
-{-# INLINE[0] assoc1 #-}
-assoc1 = A (\(Pair (Pair a b) c) -> (Pair a (Pair b c), ()))
-
-{-# INLINE[0] assoc2 #-}
-assoc2 = A (\(Pair a (Pair b c)) -> (Pair (Pair a b) c, ()))
-
-{-# INLINE[0] drop1 #-}
-drop1 = A (\(Pair Blank x) -> (x, ()))
-
-{-# INLINE[0] drop2 #-}
-drop2 = A (\(Pair x Blank) -> (x, ()))
-
-{-# INLINE[0] undrop1 #-}
-undrop1 = A (\x -> (Pair Blank x, ()))
-
-{-# INLINE[0] undrop2 #-}
-undrop2 = A (\x -> (Pair x Blank, ()))
-
-{-# INLINE[0] swap #-}
-swap = A (\(Pair x y) -> (Pair y x, ()))
-
-{-# INLINE[0] apply #-}
-apply = A (\(Pair (A f) x) -> f x)
-
-{-# INLINE[0] curry #-}
-curry (A f) = A (\x -> (A (\y -> f (Pair x y)), ()))
-
-{-# INLINE[0] distr #-}
-distr = A (\(Pair a ei) -> (either (Left . Pair a) (Right . Pair a) ei, ()))
-
-{-# INLINE[0] assoc3 #-}
-assoc3 ((x, y), z) = (x, (y, z))
-
-{-# INLINE[0] assoc4 #-}
-assoc4 (x, (y, z)) = ((x, y), z)
-
-------------------------------------------------------
-
-{-# INLINE[2] void' #-}
-void' = (>>== const (rtn ()))
-
-{-# INLINE[2] bimap' #-}
-bimap' :: A () t u -> A () v w -> A () (Pair t v) (Pair u w)
-bimap' a a2 = void' (bimap a a2)
-
-------------------------------------------------------
-
-newtype Exclusive = Exclusive Handle deriving Storable
-
-newtype Semiclosed = Semiclosed Handle deriving Storable
-
-newtype Open p = Open Handle deriving Storable
-
-class Openhandle h where
-	getHdl :: h -> Handle
-
-instance Openhandle Exclusive where
-	getHdl (Exclusive h) = h
-
-instance Openhandle (Open p) where
-	getHdl (Open h) = h
-
-{-# INLINE lift #-}
-lift f = A $ \(Pair x (St world)) -> let
-	IO g = f x
-	(# world', (y, z) #) = g world in (Pair y (St world'), z)
-
-open file mode = lift (\Blank -> liftM (\hdl -> (Exclusive hdl, ())) $ openFile file mode) . undrop1
-
-getStdin = A (\Blank -> (Open stdin, ()))
-
-getStdout = A (\Blank -> (Open stdout, ()))
-
-getStderr = A (\Blank -> (Open stderr, ()))
-
-close = drop1 . lift (\(Exclusive hdl) -> hClose hdl >> return (Blank, ()))
-
-close1 = drop1 . lift (\(Semiclosed hdl) -> hClose hdl >> return (Blank, ()))
-
-fileSize = lift (\h -> liftM ((,) h) (hFileSize (getHdl h)))
-
-setFileSize sz = lift (\h -> hSetFileSize (getHdl h) sz >> return (h, ()))
-
-eof = lift (\h -> liftM ((,) h) (hIsEOF (getHdl h)))
-
-seek mode pos = lift (\h -> hSeek (getHdl h) mode pos >> return (h, ()))
-
-tell = lift (\h -> liftM ((,) h) (hTell (getHdl h)))
-
-char = lift (\h -> liftM ((,) h) (hGetChar (getHdl h)))
-
-line = lift (\h -> liftM ((,) h) (hGetLine (getHdl h)))
-
-lookahead = lift (\h -> liftM ((,) h) (hLookAhead (getHdl h)))
-
-contents = lift (\(Exclusive hdl) -> liftM ((,) (Semiclosed hdl)) (hGetContents hdl))
-
-putC c = lift  (\h -> hPutChar (getHdl h) c >> return (h, ()))
-
-putS s = lift (\h -> hPutStr (getHdl h) s >> return (h, ()))
-
-setBinary b = lift (\h -> hSetBinaryMode (getHdl h) b >> return (h, ()))
-
-{-# NOINLINE random #-}
--- Random numbers have no interesting dependence on the world state,
--- so it is not threaded.
-random rng = A (\Blank -> unsafePerformIO $ getStdGen >>= \g -> let (x, g') = randomR rng g in setStdGen g' >> return (Blank, x))
-
---------------------------------------------------------
-
-instance Storable Blank where
-	sizeOf _ = 0
-	alignment _ = 1
-	peek _ = return Blank
-	poke _ Blank = return ()
-
-align x y = ((sizeOf x - 1) `div` alignment y + 1) * alignment y
-
-frst :: (Storable a, Storable b) => Ptr (Pair a b) -> Ptr a
-frst = castPtr
-
-secnd :: forall a b. (Storable a, Storable b) => Ptr (Pair a b) -> Ptr b
-secnd = castPtr . (`plusPtr` align (undefined :: a) (undefined :: b))
-
-instance (Storable a, Storable b) => Storable (Pair a b) where
-	sizeOf _ = align (undefined :: a) (undefined :: b) + sizeOf (undefined :: b)
-	alignment _ = alignment (undefined :: a)
-		`lcm` alignment (undefined :: b)
-	peek p = liftM2 Pair (peek (frst p)) (peek (secnd p))
-	poke p (Pair x y) = do
-		poke (frst p) x
-		poke (secnd p) y
-
-coerce :: Ptr Handle -> Ptr Int32
-coerce = castPtr
-
-instance Storable Handle where
-	sizeOf _ = 4
-	alignment _ = 4
-	peek = peek . castPtr
-	poke = poke . castPtr
-
--- | With the Fix constructor, I can build data structures of linear data.
-data Fix f = In (f (Fix f))
-
-fixInj1 :: Pointer p s (Fix f) -> Pointer p s (f (Fix f))
-fixInj1 (Pointer fp p) = Pointer fp (castPtr p)
-
-fixInj2 :: Pointer p s (f (Fix f)) -> Pointer p s (Fix f)
-fixInj2 (Pointer fp p) = Pointer fp (castPtr p)
-
-data Pointer p s t = Pointer !(ForeignPtr Blank) !(Ptr t)
-
-instance Storable (Pointer p s t) where
-	sizeOf _ = 8
-	alignment _ = 4
-	poke p (Pointer fp p2) = do
-		sp <- newStablePtr fp
-		pokeByteOff p 0 sp
-		pokeByteOff p 4 p2
-	peek p = do
-		sp <- peekByteOff p 0
-		fp <- deRefStablePtr sp
-		freeStablePtr sp
-		p2 <- peekByteOff p 4
-		return (Pointer fp p2)
-
--- | Pointers can be linear, nonlinear, or focused. There are the following
---   tradeoffs:
---
---   * Linear pointers support strong update, but can only be split
---       under focusing.
---
---   * Nonlinear pointers can be split, but do not support strong update.
---
---   Placeholders classify pointers that either point to junk or to data that
---   is not allowed to be used (to maintain linearity).
-data Linear = Linear
-
-data Focused = Focused
-
-data Nonlinear = Nonlinear
-
-data Placeholder = Placeholder
-
-class Splittable s
-
-instance Splittable Nonlinear
-
-instance Splittable Focused
-
-{-# NOINLINE dummy #-}
-dummy :: ForeignPtr Blank
-dummy = unsafePerformIO (A.malloc >>= newForeignPtr_)
-
-contraction :: A () (Pointer Nonlinear s t) (Pair (Pointer Nonlinear s t) (Pointer Nonlinear s t))
-contraction = A (\p -> (Pair p p, ()))
-
-class Weakening t where
-	weakening :: A () (Pair t St) St
-
-instance Weakening (Pointer p Focused t) where
-	weakening = A (\(Pair (Pointer _ _) st) -> (st, ()))
-
-instance Weakening (Pointer p Nonlinear t) where
-	weakening = drop1 . lift (\(Pointer fp _) -> touchForeignPtr fp >> return (Blank, ()))
-
-instance Weakening (Open p) where
-	weakening = A (\(Pair (Open _) st) -> (st, ()))
-
--- | Allocate a new linear block (containing junk), Use 'poke'' to initialize it.
-{-# NOINLINE new #-}
-new :: (Storable t) => A () St (Pair (Pointer p Placeholder t) St)
-new = lift (\Blank -> liftM (\p -> (Pointer dummy p, ())) A.malloc) . undrop1
-
--- | Use 'peek'' to take ownership of the contents of a block before freeing it.
-free :: A () (Pair (Pointer p2 Placeholder t) St) St
-free = drop1 . lift (\(Pointer _ p) -> A.free p >> return (Blank, ()))
-
--- | Split a pointer to a pair, into a pair of pointers.
-split :: forall t u p s. (Storable t, Storable u, Splittable s) => A () (Pointer p s (Pair t u)) (Pair (Pointer p s t) (Pointer p s u))
-split = A (\(Pointer fp p) -> (Pair
-	(Pointer fp (frst p))
-	(Pointer fp (secnd p)), ()))
-
-ptrSwap ::  (Storable t) => Fn (Pair (Pointer p s t) t) (Pair (Pointer p s t) t)
-ptrSwap = lift (\(Pair ptr@(Pointer _ p) x) -> peek p >>= \y -> poke p x >> return (Pair ptr y, ()))
-
--- | Focusing on a pointer.
---
---   Temporarily turns a linear pointer into a focused pointer. I get the linear
---   pointer back after all copies have been surrendered (with 'weakening').
-focus :: (forall p. A a (Pair (Pointer p Focused t) u) v)
-	-> A a (Pair (Pointer p s t) u) (Pair (Pointer p s t) v)
-focus (A f) = A (\(Pair ptr@(Pointer fp p) x) -> first (Pair ptr) (f (Pair (Pointer fp p) x)))
-
--- | Focusing on a handle.
-focusHdl :: (forall p. A a (Pair (Open p) t) u) -> A a (Pair Exclusive t) (Pair Exclusive u)
-focusHdl (A f) = A (\(Pair h@(Exclusive hdl) x) -> first (Pair h) (f (Pair (Open hdl) x)))
-
--- | Take the data out of a block, making it a placeholder.
-peek' :: (Storable t) => Fn (Pointer p Linear t) (Pair (Pointer p Placeholder t) t)
-peek' = lift (\(Pointer fp p) -> liftM (\x -> (Pair (Pointer fp p) x, ())) (peek p))
-
--- | The reverse operation.
-poke' :: (Storable t) => Fn (Pair (Pointer p Placeholder t) t) (Pointer p Linear t)
-poke' = lift (\(Pair (Pointer fp p) x) -> poke p x >> return (Pointer fp p, ()))
-
--- | A placeholder block can change its type.
-changeType :: forall t u p. (Storable t, Storable u) => A () (Pointer p Placeholder t) (Pointer p Placeholder u)
-changeType = if sizeOf (undefined :: u) <= sizeOf (undefined :: t) then
-		A (\(Pointer fp p) -> (Pointer (castForeignPtr fp) (castPtr p), ()))
-	else
-		error "Control.Linear.changeType: value won't fit"
-
--- Linearity ensures that a program must touch the pointer in order to dispose of it.
--- | Allocate a nonlinear pointer.
-{-# NOINLINE newNonlinear #-}
-newNonlinear :: (Storable t) => t -> A () Blank (Pointer p Nonlinear t)
-newNonlinear x = A (\Blank -> unsafePerformIO $ do
-	p <- A.malloc
-	poke p x
-	fp <- newForeignPtr_ p
-	return (Pointer (castForeignPtr fp) p, ()))
-
-peek1 :: (Storable t) => A t (Pair (Pointer Nonlinear s t) St) (Pair (Pointer Nonlinear s t) St)
-peek1 = lift (\ptr@(Pointer _ p) -> liftM (\x -> (ptr, x)) $ peek p)
-
-poke1 :: (Storable t) => t -> Fn (Pointer p s t) (Pointer p s t)
-poke1 x = lift (\ptr@(Pointer _ p) -> poke p x >> return (ptr, ()))
-
--- | Duplicate the world state. This is interpreted as creating a thread.
-fork :: A () St (Pair St St)
-fork = A (\st -> (Pair st st, ()))
-
--- St --------new----X
---              \
---               \
---                \
--- St ------------free----- St
---
--- By exchanging a pointer,
--- | Sync together two world states.
-{-# NOINLINE join' #-}
-join' :: A () (Pair St St) St
-join' = A (\(Pair _ st) -> (st, ())) . bimap' id free . assoc1 . bimap' (swap . (new :: A () St (Pair (Pointer p Placeholder Blank) St))) id
-
-------------------------------------------------------
---- Sample programs
-
-helloWorld = undrop1
-	>>> bimap' getStdout id
-	>>> putS "Hello world!\n"
-	>>> weakening
-
-printStuff = undrop1
-	>>> bimap' getStdout id
-	>>> iterate (putS "Stuff\n" >>>) id !! 10000
-	>>> weakening
-
-concurrent = fork
-	>>> bimap' (open "C:\\users\\james\\videos\\Biggest number.wmv" ReadMode) printStuff
-	>>> bimap' (contents >>== \text -> last text `seq` close1 >>> undrop1 >>> bimap' getStdout id >>> putS (take 10000 text)) id
-	>>> bimap' weakening id
-	>>> join'
-

@@ -0,0 +1,128 @@+{-# LANGUAGE TypeOperators, LambdaCase, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, DeriveFunctor, StandaloneDeriving, DeriveAnyClass, Safe #-}
+-- | This *is* monad coproducts (due to Luth and Ghani) unlike the other thing.
+module Control.Monad.Coproducts3 (module Control.Monad.EtaInverse, module Control.Monad.Free.Class, module Data.Functor.Sum, Free'(..), toF2, execCoproduct) where
+-- import Control.Compose
+import Data.Functor.Sum
+import Control.Monad
+import Control.Monad.Free
+import Control.Monad.Free.Class
+import Data.Functor.Classes
+import Data.Maybe
+import Control.Monad.EtaInverse
+
+-- | A modified free monad giving efficient access to the topmost layer;
+-- but otherwise using the machinery of the free monad 'f2'.
+data Free' f f2 t = Free' { unFree' :: f(f2 t) }
+	| Pure' t deriving Functor
+
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+
+instance (Functor f, MonadFree f f2) => Monad(Free' f f2) where
+	return = Pure'
+	Pure' x >>= f = f x
+	Free' f>>= f2 = Free'((\x->x>>= \x -> case f2 x of
+		Free' x2 -> wrap x2
+		Pure' x2-> return x2) <$> f)
+
+instance (Functor f, MonadFree f f2) => Applicative(Free' f f2) where
+	pure = return
+	(<*>) = ap
+
+-- | A projection into the underlying free monad construction.
+toF2 (Free' x) = wrap x
+toF2 (Pure' x) = return x
+
+instance (Functor f, MonadFree f f2) => MonadFree f(Free' f f2) where
+	-- It wraps the topmost layer contained in the layer of 'f',
+	-- then re-wraps, making the layer of 'f' the topmost layer.
+	wrap x = Free'$ toF2 <$> x
+
+deriving instance (Show1 f, Show1 f2) => Show1(Free' f f2)
+
+deriving instance (Show(f(f2 t)), Show(f2 t), Show t) => Show(Free' f f2 t)
+
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+
+----------------------------------------
+
+-- This comes from the defining map of a coproduct for layer types f and f2
+-- which correspond to layer types T and R in the paper;
+-- with the substitution made Q := Free'(Sum f f2) f3 for a free monad
+-- f3. It can be seen that this is the map (T+R) Q -> Q,
+-- which by costrength is equivalent to the two defining maps
+-- of a coproduct TQ -> Q and RQ -> Q. Checking that the diagram
+-- commutes is an exercise.
+execCoproduct_ ::  (EtaInverse f, EtaInverse f2, MonadFree(Sum f f2) f3)=>
+	Sum f f2(Free'(Sum f f2) f3 t) -> Free'(Sum f f2) f3 t
+execCoproduct_ = \ case
+
+	-- These lines implement removal of layers that are in the range
+	-- of 'eta'; in the paper these are referred to as variable layers.
+	-- This is point one on Luth and Ghani's three point checklist.
+	InL f | isJust(etaInv f) -> fromJust(etaInv f)
+
+	InR f | isJust(etaInv f) -> fromJust(etaInv f)
+
+	InL f -> Free'$InL$ f >>= \ case
+		-- Nested layers of InL are "squashed together"; the same occurs
+		-- for InR layers (this is point two).
+		Free'(InL x) -> x
+
+		Free' (InR x2) | isJust(etaInv x2) -> return$!fromJust(etaInv x2)
+		Free' x@(InR _) -> return$!wrap x
+		Pure' x -> return$!return x
+
+	InR f -> Free'$InR$ f >>= \ case
+		Free'(InR x) -> x
+		Free' (InL x2) | isJust(etaInv x2) -> return$!fromJust(etaInv x2)
+		Free' x@(InL _) -> return$!wrap x
+		Pure' x -> return$!return x
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+--
+
+
+-- Point three happens "for free"; when multiple free monad constructions are
+-- represented nested, and normalized using execCoproduct, I end up finding
+-- that the free construction also has a usable notion of 'EtaInverse', and this
+-- implements the required normalizing. Although I have to put up with three layers
+-- in T1, T2, and T3 being represented in constructors InL.InL, InR.InL, InR.
+
+--
+-- | Given a free construction construct a representation of the monad coproduct
+-- in a free mona; it picks out one representative element of each equivalence
+-- class in the defining quotient of the monad coproduct.
+execCoproduct :: (EtaInverse f, EtaInverse f2, MonadFree(Sum f f2) f3)=>
+	Free(Sum f f2) t -> Free'(Sum f f2) f3 t
+execCoproduct = iter execCoproduct_.(return<$>)

@@ -0,0 +1,54 @@+{-# LANGUAGE LambdaCase, Safe #-}
+-- | Eta inverses for some vernacular monads.
+module Control.Monad.EtaInverse where
+import Control.Monad.Writer
+import Control.Monad.Trans.Maybe
+import Control.Monad.Free
+import qualified Control.Monad.Trans.Free as TF
+import Control.Monad.Identity
+
+class (Monad f) => EtaInverse f where
+	-- Laws:
+	--
+	-- * etaInv.return = return.
+	--
+	-- * For 'x' not in the range of 'eta', etaInv x = mzero.
+	etaInv :: f t -> Maybe t
+
+instance EtaInverse Identity where
+	etaInv = return.runIdentity
+
+instance (Monoid s, Eq s) => EtaInverse((,) s) where
+	etaInv (x,x2) = do
+		-- Eta attaches an "empty" monoid result to its output; this situation
+		-- can be detected by comparing against the empty monoid value.
+		guard(x==mempty)
+		return x2
+
+instance (Monoid s, Eq s, EtaInverse f) => EtaInverse(WriterT s f) where
+	etaInv x = do
+		(x,x2) <- etaInv(runWriterT x)
+		guard(x2==mempty)
+		return x
+
+instance EtaInverse Maybe where
+	etaInv = id
+
+instance EtaInverse [] where
+	etaInv = \ case
+		[x] -> return x
+		_ -> mzero
+
+
+instance (EtaInverse f) => EtaInverse(MaybeT f) where
+	etaInv x =
+		join(etaInv(runMaybeT x))
+
+instance (Functor f) => EtaInverse(Free f) where
+	etaInv (Pure x) = return x
+	etaInv _ = mzero
+
+instance (Functor f, EtaInverse f2) => EtaInverse(TF.FreeT f f2) where
+	etaInv (TF.FreeT x) = case etaInv x of
+		Just(TF.Pure x) -> return x
+		_ -> mzero

@@ -1,114 +0,0 @@-{-# LANGUAGE Trustworthy, Rank2Types, MagicHash, UnboxedTuples, BangPatterns #-}
-
-module Control.Monad.IOT (IOT, run, module Control.Monad.Trans, module Control.Monad.Identity, module Control.Monad.Morph) where
-
-import GHC.IO (IO(IO))
-import GHC.Prim
-import Control.Monad.Trans (MonadIO(..))
-import Control.Monad.Identity
-import Control.Monad.Morph
-import Control.Monad
-import Control.Applicative
-import Control.Concurrent.MVar
-import Data.Typeable
-import Unsafe.Coerce
-
-data State = State (State# RealWorld) !(MVar ())
-
--- | An IO monad transformer.
---
--- 'IOT' cannot be unwrapped in the usual way -- the monad inside it
--- has to be unwrapped. This is done using 'run', and 'hoist' from mmorph.
---
--- Most of the safety of the IO monad is ensured statically.
--- However, to ensure that the same RealWorld token is not
--- used multiple times, a runtime check is necessary. Among
--- the alternatives that perform I/O, the first alternative
--- forced by a concatenation of 'hoist's will contain a result,
--- and subsequent alternatives will be errors.
---
--- Therefore, a concatenation of 'hoists' out of a monad defines
--- at most one path of RealWorld token use. Here is an example using
--- the binary tree monad:
---
--- >>> let io :: IOT Tree () = lift (Node (Leaf 1) (Leaf 2)) >>= liftIO . print
---
--- >>> run $ hoist (\(Node (Leaf x) _) -> Identity x) io
--- 1
---
--- >>> run $ hoist (\(Node _ (Leaf x)) -> Identity x) io
--- 2
---
--- >>> run $ hoist (\(Node (Leaf _) (Leaf x)) -> Identity x) io
--- 1
--- *** Exception: IOT: double RealWorld use
---
-newtype IOT m t = IOT (State -> m (State, t))
-
-instance (Monad m) => Monad (IOT m) where
-	{-# INLINE return #-}
-	return x = IOT $ \s -> return (s, x)
-	{-# INLINE (>>=) #-}
-	IOT f >>= g = IOT $ \s -> f s >>= \(s, x) -> let IOT h = g x in h s
-
-instance (Monad m) => Applicative (IOT m) where
-	{-# INLINE pure #-}
-	pure = return
-	{-# INLINE (<*>) #-}
-	(<*>) = ap
-
-instance (Monad m) => Functor (IOT m) where
-	{-# INLINE fmap #-}
-	fmap f m = m >>= return . f
-
-err = error "IOT: double RealWorld use"
-
-instance (Monad m) => MonadIO (IOT m) where
-	{-# INLINE liftIO #-}
-	liftIO m = IOT $ \(State s mv) -> let
-			IO f = do
-				tryTakeMVar mv >>= maybe err return
-				liftM2 (,) m (newMVar ());
-			(# s', (x, mv') #) = f s in
-		return (State s' mv', x)
-
-instance MonadTrans IOT where
-	{-# INLINE lift #-}
-	lift m = IOT $ \s -> liftM (\x -> (s, x)) m
-
-{-# INLINE _hoist #-}
-_hoist :: (forall t. m t -> n t) -> IOT m t -> IOT n t
-_hoist f (IOT g) = IOT (f . g)
-
--- Squashes together two layers of IOTs.
-{-# INLINE _squash #-}
-_squash :: (Monad m) => IOT (IOT m) t -> IOT m t
-_squash (IOT f) = do
-	mv <- liftIO $ newMVar ()
-	(State _ m, x) <- IOT (\st@(State s _) -> let IOT g = f st in g (State s mv))
-	liftIO (tryTakeMVar m) >>= maybe err return
-	return x
-
-instance MFunctor IOT where
-	{-# INLINE hoist #-}
-	hoist = _hoist
-
-instance MMonad IOT where
-	{-# INLINE embed #-}
-	embed f = _squash . _hoist f
-
--- | Run an IOT yielding an IO computation. The 'Identity' monad is a trivial wrapper around IO.
-{-# INLINE run #-}
-run :: IOT Identity t -> IO t
-run (IOT f) = do
-	mv <- newMVar ()
-	(m, x) <- IO (\s -> case f (State s mv) of
-		Identity (State s' m, x) -> (# s', (m, x) #))
-	tryTakeMVar m >>= maybe err return
-	return x
-
-{-# RULES
-"void/newMVar" forall x. void (newMVar x) = return ()
-"newMVar/tryTakeMVar" forall x. newMVar x >>= tryTakeMVar = return (Just x)
-  #-}
-

@@ -1,4 +1,4 @@-{-# LANGUAGE Unsafe, OverlappingInstances, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, TypeOperators #-}
+{-# LANGUAGE OverlappingInstances, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, TypeOperators, Safe #-}
 
 module Control.Monad.Lifter where
 
@@ -6,7 +6,7 @@ import Control.Monad.ST
 import Control.Monad.Identity
 import Control.Monad.Morph
-import Control.Monad.PlusMonad
+
 
 -- | An automatic lifter. The idea of automatic lifting is due to Dan Piponi.
 class Lifter m n where

@@ -1,202 +0,0 @@-{-# LANGUAGE Safe, Rank2Types, FlexibleInstances, DeriveFunctor, TypeOperators #-}
-
--- | A construction combining two monads, based on the work of Luth and Ghani, "Composing Monads Using Coproducts."
-module Control.Monad.PlusMonad (Composition, (::+), Dist(..), leftMap, rightMap, inl, inr, sym, commute, mapPlus, refl,
--- * Example
-File, runFile, readLine) where
-
-import qualified Control.Monad.State.Strict as Strict
-import Control.Monad.State
-import Control.Monad.Writer hiding (Sum)
-import Control.Monad.Error
-import Control.Monad.Identity
-import Control.Monad.Morph
-import Control.Monad.Codensity
-import Control.Exception
-import Control.Applicative
-import Data.Functor.Compose
-import Data.Functor.Sum
-import Data.Functor.Yoneda
-import System.IO
-
-data Composition m n t = Composition (m (n (Composition m n t))) | Rtn t deriving Functor
-
--- | The following construction on two monads is a monad provided the two monads
---   have extended distributive laws, defined below.
-type (m ::+ n) = Yoneda (Composition m n)
-
--- | An extended distributive law allows one to permute two layers.
---
--- Laws are:
---
--- >>> join . T dist = dist . join :: TTS -> TST
--- >>> TS join . dist . dist = dist :: TS -> TST
-class Dist n where
-	dist :: (Applicative m) => n (m t) -> n (m (n t))
-
--- Extended distributed laws for common monads.
-instance Dist (StateT s Identity) where
-	dist m = do
-		n <- m
-		s <- get
-		return (fmap (\x -> put s >> return x) n)
-
-instance (Monoid s) => Dist (WriterT s Identity) where
-	dist m =
-		let (n, w) = runWriter m in
-			return (fmap (\x -> tell w >> return x) n)
-
-instance Dist [] where
-	dist ls = return (sequenceA ls)
-
--- I/O is equipped with a trivial distributive law.
-instance Dist IO where
-	dist m = fmap (fmap return) m
-
-instance Dist Identity where
-	dist m = fmap (fmap return) m
-
-instance Dist Maybe where
-	dist m = fmap (fmap return) m
-
-instance Dist (Either t) where
-	dist m = fmap (fmap return) m
-
-instance (Error e) => Dist (ErrorT e Identity) where
-	dist m = fmap (fmap return) m
-
-_hoist :: (forall u. m u -> n u) -> Yoneda m t -> Yoneda n t
-_hoist f (Yoneda g) = Yoneda (f . g)
-
-_leftMap :: (Functor n, Functor x) => (forall u. m u -> n u) -> Composition m x t -> Composition n x t
-_leftMap f (Composition m) = Composition (fmap (fmap (_leftMap f)) (f m))
-_leftMap _ (Rtn x) = Rtn x
-
-_rightMap :: (Functor n, Functor x) => (forall u. m u -> n u) -> Composition x m t -> Composition x n t
-_rightMap f (Composition m) = Composition (fmap (fmap (_rightMap f) . f) m)
-_rightMap _ (Rtn x) = Rtn x
-
--- | Left and right maps...
-leftMap :: (Monad m, Functor n, Functor x) => (forall u. m u -> n u) -> (m ::+ x) t -> (n ::+ x) t
-leftMap f m = _hoist (_leftMap f) m
-
-rightMap :: (Monad x, Monad m, Functor n) => (forall u. m u -> n u) -> (x ::+ m) t -> (x ::+ n) t
-rightMap f m = _hoist (_rightMap f) m
-
--- Distribute over three layers.
-distributive1 :: (Dist m, Monad m, Applicative n, Applicative x, Applicative y) => m (n (x (y (m t)))) -> m (n (x (y (m t))))
-distributive1 m = (fmap (fmap (fmap (fmap join) . getCompose) . getCompose) . dist . fmap (Compose . fmap Compose)) m
-
--- Each layer is distributed over the inner layer in sequence, from inside to outside.
-distributive2 :: (Dist m, Dist n, Monad m, Monad n, Applicative x) => Composition m n (x (m (n t))) -> Composition m n (x (m (n t)))
-distributive2 (Composition m) = (
-	Composition
-	. fmap (fmap distributive2)
-	. fmap distributive1
-	. distributive1)
-	m
-distributive2 (Rtn x) = Rtn x
-
--- These two instances are needed to use '::+' in a nested manner.
-instance (Dist m, Dist n, Monad m, Monad n) => Dist (Composition m n) where
-	dist = fmap (fmap (Composition . fmap (fmap Rtn))) . distributive2 . fmap (fmap (return . return))
-
-instance (Dist m, Functor m) => Dist (Yoneda m) where
-	dist = liftYoneda . fmap (fmap liftYoneda) . dist . lowerYoneda
-
-distributive :: (Dist m, Monad m, Applicative n) => m (n (m t)) -> m (n (m t))
-distributive x = (fmap (fmap join) . dist) x
-
-bringDown :: (Monad m, Monad n) => Composition m n t -> m (n (Composition m n t))
-bringDown (Composition m) = m
-bringDown (Rtn x) = return (return (Rtn x))
-
-instance (Dist m, Dist n, Monad m, Monad n) => Monad (Composition m n) where
-	return = Rtn
-	Composition m >>= f = Composition ((fmap (fmap Composition)
-		. distributive
-		. fmap distributive
-		. fmap (fmap (bringDown . (>>= f))))
-		m)
-	Rtn x >>= f = f x
-	fail = Composition . fail
-
-instance (Dist m, Dist n, Monad m, MonadPlus n) => MonadPlus (Composition m n) where
-	mzero = Composition (return mzero)
-	mplus (Composition m) (Composition n) = Composition (liftM2 (liftM2 mplus) m n)
-	mplus (Rtn x) (Composition n) = Composition (liftM (return (Rtn x) `mplus`) n)
-	mplus (Composition m) (Rtn x) = Composition (liftM (mplus (return (Rtn x))) m)
-	mplus (Rtn x) (Rtn y) = Composition (return (return (Rtn x) `mplus` return (Rtn y)))
-
-instance (Dist m, Dist n, Monad m, Monad n) => Applicative (Composition m n) where
-	pure = return
-	(<*>) = ap
-
-instance (Dist m, Dist n, Monad m, MonadPlus n) => Alternative (Composition m n) where
-	empty = mzero
-	(<|>) = mplus
-
-instance (Monad m) => MonadTrans (Composition m) where
-	lift = Composition . return . fmap Rtn
-
-instance (Dist m, Dist n, Monad m, Monad n, MonadIO n) => MonadIO (Composition m n) where
-	liftIO = lift . liftIO
-
--- | Injections into the '::+' type.
-inl :: (Dist m, Dist n, Monad m, Monad n) => m t -> (m ::+ n) t
-inl m = lift (Composition (fmap (return . Rtn) m))
-
-inr :: (Dist m, Dist n, Monad m, Monad n) => n t -> (m ::+ n) t
-inr m = lift (Composition (return (fmap Rtn m)))
-
-_sym :: (Monad m) => Composition m m t -> m t
-_sym (Composition m) = m >>= (>>= _sym)
-_sym (Rtn x) = return x
-
--- | If you have a '::+' over a monad, you can extract the underlying action.
-sym :: (Monad m) => (m ::+ m) t -> m t
-sym m = _sym (lowerYoneda m)
-
-_commute :: (Monad m, Functor n) => n (Composition m n t) -> Composition n m t
-_commute n = Composition (fmap (\m -> case m of
-	Composition m -> fmap _commute m
-	Rtn x -> return (Rtn x)) n)
-
--- | '::+' is commutative.
-commute :: (Monad m, Monad n) => (m ::+ n) t -> (n ::+ m) t
-commute m = _hoist (_commute . return) m
-
-mapPlus :: (Monad m, Monad n, Functor m1, Functor n1) => (forall u. m u -> m1 u) -> (forall u. n u -> n1 u) -> (m ::+ n) t -> (m1 ::+ n1) t
-mapPlus f g = leftMap f . rightMap g
-
-refl :: (MonadPlus m) => (m ::+ m) t -> m t
-refl = sym
-
----------------------------------------
-
--- | Example of an IO-performing ADT.
-newtype File t = File (StateT Handle IO t) deriving Functor
-
-runFile (File m) path = do
-	hdl <- openFile path ReadMode
-	finally (evalStateT m hdl) (hClose hdl)
-
-readLine = File (do
-	hdl <- get
-	lift (hGetLine hdl))
-
-instance Monad File where
-	return = File . return
-	File m >>= f = File (m >>= \x -> case f x of File m -> m)
-	fail = File . fail
-
-instance Applicative File where
-	pure = return
-	(<*>) = ap
-
-instance Dist File where
-	dist m = do
-		n <- m
-		s <- File get
-		return (fmap (\x -> File (put s) >> return x) n)
-

@@ -1,23 +1,23 @@ name:                MonadCompose
-version:             0.8.4.2
+version:             0.9.0.0
 synopsis:            Methods for composing monads.
 description:         Methods for composing monads.
   .
-  The IO monad transformer solves the problem of combining two IO-performing monads, so that both may be transformed separately.
+  The I/O monad transformer, PlusMonad, and Linear modules are deprecated. Their use is discouraged. This package is now about automatic monad lifting; and includes a rigorous implementation of Luth and Ghani coproducts structured around the Free monad.
   .
-  A monad transformer can transform another monad, but if you have two monads both lacking a transformer, one can define an /extended distributive law/ which allows a monad to arise - see Control.Monad.PlusMonad.
-homepage:            http://alkalisoftware.net
+  
+-- homepage:            
 license:             BSD3
 license-file:        LICENSE
 author:              James Candy
-maintainer:          info@alkalisoftware.net
+maintainer:          jacinablackbox@yahoo.com
 -- copyright:           
 category:            Monad
 build-type:          Simple
 cabal-version:       >=1.8
 
 library
-  exposed-modules:     Control.Monad.IOT, Control.Monad.PlusMonad, Control.Monad.Lifter, Control.Linear
+  exposed-modules:     Control.Monad.Lifter, Control.Monad.Coproducts3, Control.Monad.EtaInverse
   -- other-modules: 
-  build-depends:       base >=4 && <=5, ghc-prim, mtl >= 2.2, mmorph ==1.0.*, monad-products, transformers, random, parallel >=3.2, transformers-compat ==0.4.*, kan-extensions, data-default
+  build-depends:       base >=4 && <=5, mtl >= 2.2, mmorph ==1.0.*, transformers, free ==5.1
   ghc-options:         -fno-cse