module Control.Monad.Catana (
Catana(..),
consume,
top,
push,
produce,
stop,
execCatana,
runCatana,
parallelB,
parallelE,
serial
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Cont
import Control.Monad.Fix
import Data.Either
import Data.Maybe
import System.IO.Unsafe
import Control.Concurrent.MVar
import Data.Monoid
data Catana i o b a = Catana { step :: (a -> Step i o b) -> Step i o b }
data Step i o a = Yield o (Step i o a)
| Wait (i -> Step i o a)
| Done a
instance Functor (Catana i o b) where
fmap f (Catana l) = Catana $ l . (. f)
instance Applicative (Catana i o b) where
f <*> x = Catana $ step f . flip (step . (<$> x))
pure = Catana . flip ($)
instance Monad (Catana i o b) where
return = pure
m >>= f = Catana $ step m . flip (step . f)
instance MonadCont (Catana i o b) where
callCC f = Catana $ \k -> step (f $ Catana . const . k) k
instance MonadFix (Catana i o b) where
mfix f = unsafePerformIO $ do
m <- newEmptyMVar
return $ do
x <- f . unsafePerformIO $ readMVar m
unsafePerformIO (tryPutMVar m x) `seq` return x
instance MonadPlus (Catana i o b) where
mzero = forever consume
a `mplus` b = a `parallel` b
instance Monoid (Catana i o b a) where
mempty = mzero
mappend = mplus
consume :: Catana i o a i
consume = Catana Wait
top :: Catana i o a i
top = Catana $ \k -> Wait (\i -> feed i (k i))
feed :: i -> Step i o a -> Step i o a
feed i (Yield o s) = Yield o (feed i s)
feed i (Wait s) = s i
feed _ (Done x) = Done x
stop :: b -> Catana i o b a
stop = Catana . const . Done
push :: i -> Catana i o a ()
push x = Catana $ feed x . ($())
produce :: o -> Catana i o a ()
produce x = Catana $ Yield x . ($())
execCatana :: Catana i o a a -> [i] -> [o]
execCatana c = execSteps (step c Done)
execSteps :: Step i o a -> [i] -> [o]
execSteps (Yield o s) i = o : execSteps s i
execSteps (Wait f) (i:is) = execSteps (f i) is
execSteps (Wait _) [] = []
execSteps (Done x) _ = []
runCatana :: Catana i o a a -> [i] -> (Maybe a, [o])
runCatana c i = (listToMaybe x, o)
where (x, o) = partitionEithers $ runSteps (step c Done) i
runSteps :: Step i o a -> [i] -> [Either a o]
runSteps (Yield o s) i = Right o : runSteps s i
runSteps (Wait f) (i:is) = runSteps (f i) is
runSteps (Wait _) [] = []
runSteps (Done x) _ = [Left x]
parStepsB :: Step i o a -> Step i o b -> ((a,b) -> Step i o c) -> Step i o c
parStepsB (Yield oA sA) (Yield oB sB) k = Yield oA . Yield oB $ parStepsB sA sB k
parStepsB (Yield oA sA) sB k = Yield oA $ parStepsB sA sB k
parStepsB sA (Yield oB sB) k = Yield oB $ parStepsB sA sB k
parStepsB (Wait fA) (Wait fB) k = Wait $ \i -> parStepsB (fA i) (fB i) k
parStepsB (Wait fA) sB k = Wait $ \i -> parStepsB (fA i) sB k
parStepsB sA (Wait fB) k = Wait $ \i -> parStepsB sA (fB i) k
parStepsB (Done xA) (Done xB) k = k (xA, xB)
parallelB :: Catana i o a a -> Catana i o b b -> Catana i o c (a, b)
parallelB a b = Catana $ parStepsB (step a Done) (step b Done)
parStepsE :: Step i o a -> Step i o b -> (Either a b -> Step i o c) -> Step i o c
parStepsE (Yield oA sA) (Yield oB sB) k = Yield oA . Yield oB $ parStepsE sA sB k
parStepsE (Yield oA sA) sB k = Yield oA $ parStepsE sA sB k
parStepsE sA (Yield oB sB) k = Yield oB $ parStepsE sA sB k
parStepsE (Done xA) _ k = k (Left xA)
parStepsE _ (Done xB) k = k (Right xB)
parStepsE (Wait fA) (Wait fB) k = Wait $ \i -> parStepsE (fA i) (fB i) k
parallelE :: Catana i o a a -> Catana i o b b -> Catana i o c (Either a b)
parallelE a b = Catana $ parStepsE (step a Done) (step b Done)
parallel a b = Catana $ \k -> parStepsB (step a k)
(step b k) (error "parallel ran out")
serSteps :: Step io o a -> Step i io b -> (Either a b -> Step i o c) -> Step i o c
serSteps (Yield oA sA) sB k = Yield oA $ serSteps sA sB k
serSteps (Done xA) _ k = k (Left xA)
serSteps _ (Done xB) k = k (Right xB)
serSteps (Wait fA) (Yield oB sB) k = serSteps (fA oB) sB k
serSteps sA (Wait fB) k = Wait $ \i -> serSteps sA (fB i) k
serial :: Catana io o a a -> Catana i io b b -> Catana i o c (Either a b)
serial a b = Catana $ serSteps (step a Done) (step b Done)