packages feed

MonadCompose 0.8.2.0 → 0.8.3.0

raw patch · 6 files changed

+213/−120 lines, 6 filesdep +comonaddep +monad-loopsdep +parallel

Dependencies added: comonad, monad-loops, parallel, transformers-compat

Files

Control/Linear.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, ScopedTypeVariables, MagicHash, UnboxedTuples, FlexibleInstances, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}
+{-# 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
@@ -6,7 +6,7 @@ --   (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, void', bimap',
+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
@@ -16,12 +16,17 @@ -- ** Strong update
 peek', poke', changeType,
 -- ** Operations on nonlinear data / Weak update
-newNonlinear, peek1, poke1
+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#)
@@ -35,7 +40,7 @@ import Data.Default
 import Data.Int
 import Prelude hiding (id, (.), curry)
-import System.Random (getStdGen)
+import System.Random hiding (split, random)
 import System.IO.Unsafe
 
 -- * Linear type machinery
@@ -50,11 +55,11 @@ 
 data Blank = Blank
 
-data Pair t u = Pair !t !u
+data Pair t u = Pair t u
 
 instance (Default a) => Category (A a) where
-	id = A (\x -> (x, def))
-	A f . A g = A (f . fst . g)
+	id = rtn def
+	a . a2 = a2 >>== \(_ :: a) -> a
 
 instance (Default a) => Arrow (A a) where
 	arr f = A (\x -> (f x, def))
@@ -69,64 +74,98 @@ infixl 1 >>==
 
 -- | Monadic bind (for nonlinear data).
-A f >>== g = A (\x -> let
-	(y, z) = f x
-	A h = g z in
-	h y)
+{-# 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 run #-}
+{-# 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 bimap #-}
+{-# INLINE[0] bimap #-}
 bimap (A f) (A g) = A (\(Pair a b) -> let
 	(c, d) = f a
 	(e, h) = g b in
-	(Pair c e, (d, h)))
+	(c `par` e) `seq` (Pair c e, (d, h)))
 
-{-# INLINE assoc1 #-}
+{-# INLINE[0] assoc1 #-}
 assoc1 = A (\(Pair (Pair a b) c) -> (Pair a (Pair b c), ()))
 
-{-# INLINE assoc2 #-}
+{-# INLINE[0] assoc2 #-}
 assoc2 = A (\(Pair a (Pair b c)) -> (Pair (Pair a b) c, ()))
 
-{-# INLINE drop1 #-}
+{-# INLINE[0] drop1 #-}
 drop1 = A (\(Pair Blank x) -> (x, ()))
 
-{-# INLINE drop2 #-}
+{-# INLINE[0] drop2 #-}
 drop2 = A (\(Pair x Blank) -> (x, ()))
 
-{-# INLINE undrop1 #-}
+{-# INLINE[0] undrop1 #-}
 undrop1 = A (\x -> (Pair Blank x, ()))
 
-{-# INLINE undrop2 #-}
+{-# INLINE[0] undrop2 #-}
 undrop2 = A (\x -> (Pair x Blank, ()))
 
-{-# INLINE swap #-}
+{-# INLINE[0] swap #-}
 swap = A (\(Pair x y) -> (Pair y x, ()))
 
-{-# INLINE apply #-}
+{-# INLINE[0] apply #-}
 apply = A (\(Pair (A f) x) -> f x)
 
-{-# INLINE curry #-}
+{-# INLINE[0] curry #-}
 curry (A f) = A (\x -> (A (\y -> f (Pair x y)), ()))
 
-{-# INLINE distr #-}
+{-# 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)
+
+{-# RULES
+"assoc"[1] forall a a2 a3. assoc1 >>== \_ -> bimap a (bimap a2 a3) = bimap (bimap a a2) a3 >>== \x -> assoc1 >>== \_ -> rtn (assoc3 x)
+"assoc2"[1] forall a a2 a3. assoc2 >>== \_ -> bimap (bimap a a2) a3 = bimap a (bimap a2 a3) >>== \x -> assoc2 >>== \_ -> rtn (assoc4 x)
+"drop"[1] forall a. drop1 >>== \_ -> a = bimap id a >>== \((), x) -> drop1 >>== \_ -> rtn x
+"drop2"[1] forall a. drop2 >>== \_ -> a = bimap a id >>== \(x, ()) -> drop2 >>== \_ -> rtn x
+"swap"[1] forall a a2. swap >>== \_ -> bimap a a2 = bimap a2 a >>== \(x, y) -> swap >>== \_ -> rtn (y, x)
+"fuseMaps"[1] forall a a2 a3 a4. bimap a3 a4 >>== \_ -> bimap a a2
+	= bimap (a3 >>== \_ -> a) (a4 >>== \_ -> a2)
+"fuseMaps2"[1] forall a a2 a3 a4. bimap a3 a4 >>== \(x, y) -> bimap (a x) (a2 y)
+	= bimap (a3 >>== a) (a4 >>== a2)
+"fuseMaps3"[1] forall a a2 a3 a4 a5. bimap a3 a4 >>== \_ -> bimap a a2 >>== a5
+	= bimap (a3 >>== \_ -> a) (a4 >>== \_ -> a2) >>== a5
+"fuseMaps4"[1] forall a a2 a3 a4 a5. bimap a3 a4 >>== \(x, y) -> bimap (a x) (a2 y) >>== a5
+	= bimap (a3 >>== a) (a4 >>== a2) >>== a5
+"monad"[1] forall x a. rtn x >>== a = a x
+"monad2"[1] forall a a2 a3. a >>== a2 >>== a3 = a >>== \x -> a2 x >>== a3
+"drop3"[1] drop1 >>== \_ -> undrop1 = id
+"drop4"[1] drop2 >>== \_ -> undrop2 = id
+"drop5"[1] undrop1 >>== \_ -> drop1 = id
+"drop6"[1] undrop2 >>== \_ -> drop2 = id
+"assoc3"[1] assoc1 >>== \_ -> assoc2 = id
+"assoc4"[1] assoc2 >>== \_ -> assoc1 = id
+"swap2"[1] swap >>== \_ -> swap = id
+"inlinearrow" forall a a2. a >>> a2 = a2 . a
+"inlinecompose" forall a a2. a . a2 = a2 >>== \_ -> a
+  #-}
+
 ------------------------------------------------------
 
-{-# INLINE void' #-}
+{-# INLINE[2] void' #-}
 void' = (>>== const (rtn ()))
 
-{-# INLINE bimap' #-}
+{-# INLINE[2] bimap' #-}
 bimap' :: A () t u -> A () v w -> A () (Pair t v) (Pair u w)
 bimap' a a2 = void' (bimap a a2)
 
@@ -186,10 +225,12 @@ 
 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 = A (\Blank -> unsafePerformIO $ liftM ((,) Blank) getStdGen)
+random rng = A (\Blank -> unsafePerformIO $ getStdGen >>= \g -> let (x, g') = randomR rng g in setStdGen g' >> return (Blank, x))
 
 --------------------------------------------------------
 
@@ -229,17 +270,17 @@ data Fix f = In (f (Fix f))
 
 fixInj1 :: Pointer p s (Fix f) -> Pointer p s (f (Fix f))
-fixInj1 (Pointer fp p world) = Pointer fp (castPtr p) world
+fixInj1 (Pointer fp p) = Pointer fp (castPtr p)
 
 fixInj2 :: Pointer p s (f (Fix f)) -> Pointer p s (Fix f)
-fixInj2 (Pointer fp p world) = Pointer fp (castPtr p) world
+fixInj2 (Pointer fp p) = Pointer fp (castPtr p)
 
-data Pointer p s t = Pointer !(ForeignPtr Blank) !(Ptr t) (State# RealWorld)
+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 -- The RealWorld is lost...
+	poke p (Pointer fp p2) = do
 		sp <- newStablePtr fp
 		pokeByteOff p 0 sp
 		pokeByteOff p 4 p2
@@ -248,7 +289,7 @@ 		fp <- deRefStablePtr sp
 		freeStablePtr sp
 		p2 <- peekByteOff p 4
-		IO (\s -> (# s, Pointer fp p2 s #)) -- ...so produce one here.
+		return (Pointer fp p2)
 
 -- | Pointers can be linear, nonlinear, or focused. There are the following
 --   tradeoffs:
@@ -268,11 +309,11 @@ 
 data Placeholder = Placeholder
 
-class Splitable s
+class Splittable s
 
-instance Splitable Nonlinear
+instance Splittable Nonlinear
 
-instance Splitable Focused
+instance Splittable Focused
 
 {-# NOINLINE dummy #-}
 dummy :: ForeignPtr Blank
@@ -282,70 +323,59 @@ contraction = A (\p -> (Pair p p, ()))
 
 class Weakening t where
-	weakening :: A () t Blank
+	weakening :: A () (Pair t St) St
 
 instance Weakening (Pointer p Focused t) where
-	weakening = A (\(Pointer _ _ _) -> (Blank, ()))
+	weakening = A (\(Pair (Pointer _ _) st) -> (st, ()))
 
 instance Weakening (Pointer p Nonlinear t) where
-	weakening = A (\(Pointer fp _ world) -> let IO f = touchForeignPtr fp in
-		case f world of (# _, () #) -> (Blank, ()))
+	weakening = drop1 . lift (\(Pointer fp _) -> touchForeignPtr fp >> return (Blank, ()))
 
 instance Weakening (Open p) where
-	weakening = A (\(Open _) -> (Blank, ()))
+	weakening = A (\(Pair (Open _) st) -> (st, ()))
 
 -- | Allocate a new linear block (containing junk), Use 'poke'' to initialize it.
 {-# NOINLINE new #-}
-new :: (Storable t) => A () Blank (Pointer p Placeholder t)
-new = A (\Blank -> unsafePerformIO (liftM (\p -> (Pointer dummy p realWorld#, ())) A.malloc))
+new :: (Storable t) => A () St (Pair (Pointer p Placeholder t) St)
+new = lift (\Blank -> liftM (\p -> (Pointer dummy p, ())) A.malloc) . undrop1
 
--- By using a smuggled RealWorld, I sequence freeing of a pointer without
--- requiring explicit world sequencing.
 -- | Use 'peek'' to take ownership of the contents of a block before freeing it.
-free :: A () (Pointer p2 Placeholder t) Blank
-free = A (\(Pointer _ p world) -> let IO f = A.free p in
-	case f world of (# _, () #) -> (Blank, ()))
+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, Splitable 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) realWorld#)
-	(Pointer fp (secnd p) realWorld#), ()))
+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, ())) >>> updateWorld1
+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) (Pair v St))
-	-> A a (Pair (Pointer p s t) u) (Pair (Pair (Pointer p s t) v) St)
-focus (A f) = A (\(Pair ptr@(Pointer fp p _) x) -> first (\(Pair x st) -> Pair (Pair ptr x) st) (f (Pair (Pointer fp p realWorld#) x))) >>== \x -> updateWorld1 >>== \_ -> rtn x
+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)))
 
-updateWorld :: A () (Pair (Pointer p s t) St) (Pair (Pointer p s t) St)
-updateWorld = A (\(Pair (Pointer fp p _) st@(St world)) -> (Pair (Pointer fp p world) st, ()))
-
-manipulate = assoc2 . bimap' id swap . assoc1
-
-updateWorld1 = manipulate . bimap' updateWorld id . manipulate
-
 -- | 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' = updateWorld1 . lift (\(Pointer fp p st) -> liftM (\x -> (Pair (Pointer fp p st) x, ())) (peek p))
+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' = updateWorld . lift (\(Pair (Pointer fp p world) x) -> poke p x >> return (Pointer fp p world, ()))
+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 world) -> (Pointer (castForeignPtr fp) (castPtr p) world, ()))
+		A (\(Pointer fp p) -> (Pointer (castForeignPtr fp) (castPtr p), ()))
 	else
 		error "Control.Linear.changeType: value won't fit"
 
@@ -357,20 +387,46 @@ 	p <- A.malloc
 	poke p x
 	fp <- newForeignPtr_ p
-	return (Pointer (castForeignPtr fp) p realWorld#, ()))
+	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) >>== \x -> updateWorld >>== \_ -> rtn x
+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, ())) >>> updateWorld
+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 = run $ undrop1
+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
-	>>> drop1
+	>>> join'
Control/Monad/Distributive.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FunctionalDependencies, TypeOperators #-}
+{-# LANGUAGE Safe, MultiParamTypeClasses, FlexibleContexts, FunctionalDependencies, TypeOperators #-}
 
 module Control.Monad.Distributive where
 
@@ -75,4 +75,4 @@ ldist' m = putin $ ldist m
 
 -- | Right distributivity.
-rdist' m = rdist (takeout m) >>= combine
+rdist' m = rdist (takeout m) >>= lift . combine
Control/Monad/IOT.hs view
@@ -1,80 +1,114 @@-{-# LANGUAGE MagicHash, UnboxedTuples, Rank2Types, GADTs #-}
+{-# LANGUAGE Trustworthy, Rank2Types, MagicHash, UnboxedTuples, BangPatterns #-}
 
-module Control.Monad.IOT (IOT, run) where
+module Control.Monad.IOT (IOT, run, module Control.Monad.Trans, module Control.Monad.Identity, module Control.Monad.Morph) where
 
-import GHC.IO hiding (liftIO)
+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 Ret a = Ret (State# RealWorld) a
-
-data Sequence m where
-	None :: Sequence m
-	Seq :: (Monad m) => IO (Ret ()) -> Sequence (IOT m)
-
-{-# NOINLINE runSequence #-}
-runSequence :: (Monad m) => Sequence m -> State# RealWorld -> m (Ret ())
-runSequence None s = return (Ret s ())
-runSequence (Seq io) _ = liftIO io
+data State = State !(State# RealWorld) !(MVar ())
 
 -- | An IO monad transformer.
 --
--- I can't run 'IOT'. Instead, I run the monad inside it.
--- This is done using 'run', and 'hoist' from mmorph.
+-- '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.
 --
--- The combination is only a monad if the parameter monad
--- isn't nondeterministic. IOT Maybe and IOT State are
--- monads, but IOT [] and IOT Cont are not.
+-- 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.
 --
--- Should be integrated with STT.
-
-newtype IOT m t = IOT (Sequence m -> State# RealWorld -> m (Ret t))
+-- 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
-	return x = IOT (\_ s -> return (Ret s x))
-	IOT f >>= g = IOT (\i s -> f i s >>= \(Ret s2 x) -> case g x of
-		IOT h -> h i s2)
+	{-# 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
-	liftIO (IO f) = IOT (\_ s -> case f s of
-		(# s2, x #) -> return (Ret s2 x))
+	{-# 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
-	lift m = IOT (\i s -> m >>= \x -> liftM (\(Ret s ()) -> Ret s x) (runSequence i s))
-
--- Flatten two layers into one. mmorph exports 'squash'.
---
--- Unsafely interleave actions in the outer monad, but sequence with the
--- inner monad using a sequencing fn.
-_squash (IOT f) = IOT (\i s -> let IOT g = f (Seq $ IO $ \s -> (# s, Ret s () #)) s in g i s >>= \(Ret _ pr) -> return pr)
+	{-# 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 (\i s -> f (g (unsafeCoerce i) s))
--- Type safety proof: the datum i is either in None or Seq.
---   * If it is in None, it is valid at all types.
---   * If it is in Seq, the only way it can be projected is from IOT m to IO
---   and back again. liftIO is valid at both. So 'runSequence' will
---   certainly be used at a valid type.
+_hoist f (IOT g) = IOT (f . g)
 
-instance MMonad IOT where
-	embed f = _squash . _hoist f
+-- 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
 
--- | Run an IOT.
+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) = IO (\s -> case runIdentity (f None s) of
-	Ret s2 x -> (# s2, x #))
+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)
+  #-}
+
Control/Monad/Lifter.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverlappingInstances, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, TypeOperators #-}
+{-# LANGUAGE Unsafe, OverlappingInstances, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, TypeOperators #-}
 
 module Control.Monad.Lifter where
Control/Monad/PlusMonad.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE RankNTypes, TypeOperators #-}
+{-# LANGUAGE Safe, TypeOperators, RankNTypes, DeriveFunctor #-}
 
 -- | The Plus monad - a free combination of monads. This is very similar to coproducts, but not quite the same.
 --
 --   Coproducts are due to Luth and Ghani, "Composing Monads Using Coproducts," http://www.informatik.uni-bremen.de/~cxl/papers/icfp02.pdf
+--
+
 module Control.Monad.PlusMonad where
 
 import Control.Monad.Trans
MonadCompose.cabal view
@@ -1,5 +1,5 @@ name:                MonadCompose
-version:             0.8.2.0
+version:             0.8.3.0
 synopsis:            Methods for composing monads.
 description:         Methods for composing monads.
   .
@@ -21,4 +21,5 @@ library
   exposed-modules:     Control.Monad.IOT, Control.Monad.Distributive, Control.Monad.PlusMonad, Control.Monad.Lifter, Control.Linear
   -- other-modules: 
-  build-depends:       base >=4 && <=5, ghc-prim ==0.3.*, mtl ==2.1.*, mmorph ==1.0.*, monad-products, transformers, MaybeT, random, data-default
+  build-depends:       base >=4 && <=5, ghc-prim ==0.3.*, mtl ==2.1.*, mmorph ==1.0.*, monad-products, transformers, MaybeT, random, data-default, parallel ==3.2.*, comonad ==3.0.*, transformers-compat ==0.4.*, monad-loops >= 0.4.2.1
+  ghc-options:         -fno-cse