    {-# 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)      = IOSpec f b -> (ThreadId -> b) -> ForkS b
    forall a (f :: * -> *) b.
    Executable f =>
    IOSpec f b -> (ThreadId -> a) -> ForkS a
    Fork IOSpec f b
    l (a -> b
    f (a -> b) -> (ThreadId -> a) -> ThreadId -> b
    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 =  ForkS (IOSpec g ThreadId) -> IOSpec g ThreadId
    forall (g :: * -> *) (f :: * -> *) a.
    (g :<: f) =>
    g (IOSpec f a) -> IOSpec f a
    inject (IOSpec f a
    -> (ThreadId -> IOSpec g ThreadId) -> ForkS (IOSpec g ThreadId)
    forall a (f :: * -> *) b.
    Executable f =>
    IOSpec f b -> (ThreadId -> a) -> ForkS a
    Fork IOSpec f a
    p ThreadId -> IOSpec g ThreadId
    forall a. a -> IOSpec g a
    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
        tid <- VM ThreadId
    freshThreadId
        updateSoup tid t
        return (Step (p tid))