{-# LANGUAGE ExistentialQuantification, FlexibleContexts, TypeOperators #-}
-- | A pure specification of 'forkIO'.
module Test.IOSpec.Fork
   (
     ForkS
   , forkIO
   )
   where

import Test.IOSpec.VirtualMachine
import Test.IOSpec.Types

-- The 'ForkS' data type and its instances.
--
-- | An expression of type @IOSpec ForkS a@ corresponds to an 'IO'
-- computation that uses 'forkIO' and returns a value of
-- type 'a'.
--
-- By itself, 'ForkS' is not terribly useful. You will probably want
-- to use @IOSpec (ForkS :+: MVarS)@ or @IOSpec (ForkS :+: STMS)@.
data ForkS a =
  forall f b . Executable f => Fork (IOSpec f b) (ThreadId -> a)

instance Functor ForkS where
  fmap :: forall a b. (a -> b) -> ForkS a -> ForkS b
fmap a -> b
f (Fork IOSpec f b
l ThreadId -> a
io)      = forall a (f :: * -> *) b.
Executable f =>
IOSpec f b -> (ThreadId -> a) -> ForkS a
Fork IOSpec f b
l (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> a
io)

-- | The 'forkIO' function forks off a new thread.
forkIO :: (Executable f, ForkS :<: g) => IOSpec f a -> IOSpec g ThreadId
forkIO :: forall (f :: * -> *) (g :: * -> *) a.
(Executable f, ForkS :<: g) =>
IOSpec f a -> IOSpec g ThreadId
forkIO IOSpec f a
p =  forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject (forall a (f :: * -> *) b.
Executable f =>
IOSpec f b -> (ThreadId -> a) -> ForkS a
Fork IOSpec f a
p forall (m :: * -> *) a. Monad m => a -> m a
return)

instance Executable ForkS where
  step :: forall a. ForkS a -> VM (Step a)
step (Fork IOSpec f b
t ThreadId -> a
p) = do
    ThreadId
tid <- VM ThreadId
freshThreadId
    forall (f :: * -> *) a.
Executable f =>
ThreadId -> IOSpec f a -> VM ()
updateSoup ThreadId
tid IOSpec f b
t
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Step a
Step (ThreadId -> a
p ThreadId
tid))