module Control.Effect.Thread (
EffectThread, Thread,
runMain, runSync, runAsync,
yield, fork, abort,
) where
import Control.Effect.Lift
import Control.Monad.Effect
import Control.Applicative ((<$>))
import Control.Monad (void)
import qualified Control.Concurrent as IO
data Thread a = Yield a | Fork a a | Abort
deriving Functor
type EffectThread = Member Thread
yield :: EffectThread es => Effect es ()
yield = send (Yield ())
fork :: EffectThread es => Effect es () -> Effect es ()
fork child = sendEffect $ Fork child (return ())
abort :: EffectThread es => Effect es ()
abort = send Abort
runMain :: Effect (Thread ': es) () -> Effect es ()
runMain = run [] . toAST
where
run auxThreads thread = do
result <- thread
case result of
AbortAST -> return ()
YieldAST k -> do
auxThreads' <- runAll auxThreads
run auxThreads' k
ForkAST child parent -> do
auxThreads' <- runAll [child]
run (auxThreads ++ auxThreads') parent
runAll [] = return []
runAll (thread:xs) = do
result <- thread
case result of
AbortAST -> runAll xs
YieldAST k -> (k:) <$> runAll xs
ForkAST child parent -> (parent:) <$> runAll (child:xs)
runSync :: Effect (Thread ': es) () -> Effect es ()
runSync = run . (:[]) . toAST
where
run [] = return ()
run (thread:xs) = do
result <- thread
case result of
AbortAST -> run xs
YieldAST k -> run (xs ++ [k])
ForkAST child parent -> run (child:xs ++ [parent])
runAsync :: Effect '[Thread, Lift IO] () -> IO ()
runAsync = run . toAST
where
run thread = do
result <- runLift thread
case result of
AbortAST -> return ()
YieldAST k -> do
IO.yield
run k
ForkAST child parent -> do
void $ IO.forkIO $ run child
run parent
data ThreadAST es
= YieldAST (Effect es (ThreadAST es))
| ForkAST (Effect es (ThreadAST es)) (Effect es (ThreadAST es))
| AbortAST
toAST :: Effect (Thread ': es) () -> Effect es (ThreadAST es)
toAST =
handle (\() -> return AbortAST)
$ eliminate (\thread ->
case thread of
Abort -> return AbortAST
Yield k -> return (YieldAST k)
Fork child parent -> return (ForkAST child parent))
$ defaultRelay