    {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, TypeOperators #-}
    -- | A pure specification of basic operations on MVars.

    module Test.IOSpec.MVar
       (
       -- * The 'MVarS' spec
         MVarS
       -- * Supported functions
       , MVar
       , newEmptyMVar
       , takeMVar
       , putMVar
       )
       where

    import Data.Dynamic
    import Data.Maybe (fromJust)
    import Test.IOSpec.Types
    import Test.IOSpec.VirtualMachine

    -- The 'MVarS' data type and its instances.
    --
    -- | An expression of type @IOSpec MVarS a@ corresponds to an @IO@
    -- computation that uses shared, mutable variables and returns a
    -- value of type @a@.
    --
    -- By itself, 'MVarS' is not terribly useful. You will probably want
    -- to use @IOSpec (ForkS :+: MVarS)@.

    data MVarS a =
         NewEmptyMVar (Loc -> a)
      |  TakeMVar Loc (Data -> a)
      |  PutMVar Loc Data a

    instance Functor MVarS where
      fmap :: forall a b. (a -> b) -> MVarS a -> MVarS b
    fmap a -> b
    f (NewEmptyMVar Loc -> a
    io) = (Loc -> b) -> MVarS b
    forall a. (Loc -> a) -> MVarS a
    NewEmptyMVar (a -> b
    f (a -> b) -> (Loc -> a) -> Loc -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Loc -> a
    io)
      fmap a -> b
    f (TakeMVar Loc
    l Data -> a
    io) = Loc -> (Data -> b) -> MVarS b
    forall a. Loc -> (Data -> a) -> MVarS a
    TakeMVar Loc
    l (a -> b
    f (a -> b) -> (Data -> a) -> Data -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Data -> a
    io)
      fmap a -> b
    f (PutMVar Loc
    l Data
    d a
    io) = Loc -> Data -> b -> MVarS b
    forall a. Loc -> Data -> a -> MVarS a
    PutMVar Loc
    l Data
    d (a -> b
    f a
    io)

    -- | An 'MVar' is a shared, mutable variable.
    newtype MVar a = MVar Loc deriving Typeable

    -- | The 'newEmptyMVar' function creates a new 'MVar' that is initially empty.
    newEmptyMVar        :: (Typeable a, MVarS :<: f) => IOSpec f (MVar a)
    newEmptyMVar :: forall a (f :: * -> *).
    (Typeable a, MVarS :<: f) =>
    IOSpec f (MVar a)
    newEmptyMVar        = MVarS (IOSpec f (MVar a)) -> IOSpec f (MVar a)
    forall (g :: * -> *) (f :: * -> *) a.
    (g :<: f) =>
    g (IOSpec f a) -> IOSpec f a
    inject (MVarS (IOSpec f (MVar a)) -> IOSpec f (MVar a))
    -> MVarS (IOSpec f (MVar a)) -> IOSpec f (MVar a)
    forall a b. (a -> b) -> a -> b
    $ (Loc -> IOSpec f (MVar a)) -> MVarS (IOSpec f (MVar a))
    forall a. (Loc -> a) -> MVarS a
    NewEmptyMVar (MVar a -> IOSpec f (MVar a)
    forall a. a -> IOSpec f a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (MVar a -> IOSpec f (MVar a))
    -> (Loc -> MVar a) -> Loc -> IOSpec f (MVar a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Loc -> MVar a
    forall a. Loc -> MVar a
    MVar)

    -- | The 'takeMVar' function removes the value stored in an
    -- 'MVar'. If the 'MVar' is empty, the thread is blocked.
    takeMVar            :: (Typeable a, MVarS :<: f) => MVar a -> IOSpec f a
    takeMVar :: forall a (f :: * -> *).
    (Typeable a, MVarS :<: f) =>
    MVar a -> IOSpec f a
    takeMVar (MVar Loc
    l)   = MVarS (IOSpec f a) -> IOSpec f a
    forall (g :: * -> *) (f :: * -> *) a.
    (g :<: f) =>
    g (IOSpec f a) -> IOSpec f a
    inject (MVarS (IOSpec f a) -> IOSpec f a)
    -> MVarS (IOSpec f a) -> IOSpec f a
    forall a b. (a -> b) -> a -> b
    $ Loc -> (Data -> IOSpec f a) -> MVarS (IOSpec f a)
    forall a. Loc -> (Data -> a) -> MVarS a
    TakeMVar Loc
    l (a -> IOSpec f a
    forall a. a -> IOSpec f a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a -> IOSpec f a) -> (Data -> a) -> Data -> IOSpec f a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Maybe a -> a
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe a -> a) -> (Data -> Maybe a) -> Data -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Data -> Maybe a
    forall a. Typeable a => Data -> Maybe a
    fromDynamic)

    -- | The 'putMVar' function fills an 'MVar' with a new value. If the
    -- 'MVar' is not empty, the thread is blocked.
    putMVar             :: (Typeable a, MVarS :<: f) => MVar a -> a -> IOSpec f ()
    putMVar :: forall a (f :: * -> *).
    (Typeable a, MVarS :<: f) =>
    MVar a -> a -> IOSpec f ()
    putMVar (MVar Loc
    l) a
    d  = MVarS (IOSpec f ()) -> IOSpec f ()
    forall (g :: * -> *) (f :: * -> *) a.
    (g :<: f) =>
    g (IOSpec f a) -> IOSpec f a
    inject (MVarS (IOSpec f ()) -> IOSpec f ())
    -> MVarS (IOSpec f ()) -> IOSpec f ()
    forall a b. (a -> b) -> a -> b
    $ Loc -> Data -> IOSpec f () -> MVarS (IOSpec f ())
    forall a. Loc -> Data -> a -> MVarS a
    PutMVar Loc
    l (a -> Data
    forall a. Typeable a => a -> Data
    toDyn a
    d) (() -> IOSpec f ()
    forall a. a -> IOSpec f a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    instance Executable MVarS where
      step :: forall a. MVarS a -> VM (Step a)
    step (NewEmptyMVar Loc -> a
    t) = do loc <- VM Loc
    alloc
                                 emptyLoc loc
                                 return (Step (t loc))
      step (TakeMVar Loc
    loc Data -> a
    t) = do var <- Loc -> VM (Maybe Data)
    lookupHeap Loc
    loc
                                 case var of
                                   Maybe Data
    Nothing -> Step a -> StateT Store Effect (Step a)
    forall a. a -> StateT Store Effect a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Step a
    forall a. Step a
    Block
                                   Just Data
    x -> do
                                     Loc -> VM ()
    emptyLoc Loc
    loc
                                     Step a -> StateT Store Effect (Step a)
    forall a. a -> StateT Store Effect a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a -> Step a
    forall a. a -> Step a
    Step (Data -> a
    t Data
    x))
      step (PutMVar Loc
    loc Data
    d a
    t) = do var <- Loc -> VM (Maybe Data)
    lookupHeap Loc
    loc
                                  case var of
                                    Maybe Data
    Nothing -> do
                                      Loc -> Data -> VM ()
    updateHeap Loc
    loc Data
    d
                                      Step a -> StateT Store Effect (Step a)
    forall a. a -> StateT Store Effect a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a -> Step a
    forall a. a -> Step a
    Step a
    t)
                                    Just Data
    _ -> Step a -> StateT Store Effect (Step a)
    forall a. a -> StateT Store Effect a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Step a
    forall a. Step a
    Block