{-# 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) = forall a. (Loc -> a) -> MVarS a
NewEmptyMVar (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> a
io)
  fmap a -> b
f (TakeMVar Loc
l Data -> a
io) = forall a. Loc -> (Data -> a) -> MVarS a
TakeMVar Loc
l (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> a
io)
  fmap a -> b
f (PutMVar Loc
l Data
d a
io) = 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        = forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject forall a b. (a -> b) -> a -> b
$ forall a. (Loc -> a) -> MVarS a
NewEmptyMVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)   = forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject forall a b. (a -> b) -> a -> b
$ forall a. Loc -> (Data -> a) -> MVarS a
TakeMVar Loc
l (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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  = forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject forall a b. (a -> b) -> a -> b
$ forall a. Loc -> Data -> a -> MVarS a
PutMVar Loc
l (forall a. Typeable a => a -> Data
toDyn a
d) (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
loc <- VM Loc
alloc
                             Loc -> VM ()
emptyLoc Loc
loc
                             forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Step a
Step (Loc -> a
t Loc
loc))
  step (TakeMVar Loc
loc Data -> a
t) = do Maybe Data
var <- Loc -> VM (Maybe Data)
lookupHeap Loc
loc
                             case Maybe Data
var of
                               Maybe Data
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Step a
Block
                               Just Data
x -> do
                                 Loc -> VM ()
emptyLoc Loc
loc
                                 forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Step a
Step (Data -> a
t Data
x))
  step (PutMVar Loc
loc Data
d a
t) = do Maybe Data
var <- Loc -> VM (Maybe Data)
lookupHeap Loc
loc
                              case Maybe Data
var of
                                Maybe Data
Nothing -> do
                                  Loc -> Data -> VM ()
updateHeap Loc
loc Data
d
                                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Step a
Step a
t)
                                Just Data
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Step a
Block