{-# 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 :: (a -> b) -> MVarS a -> MVarS b
fmap f :: a -> b
f (NewEmptyMVar io :: 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 f :: a -> b
f (TakeMVar l :: Loc
l io :: 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 f :: a -> b
f (PutMVar l :: Loc
l d :: Data
d io :: 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 :: 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 (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 :: MVar a -> IOSpec f a
takeMVar (MVar l :: 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 (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 :: MVar a -> a -> IOSpec f ()
putMVar (MVar l :: Loc
l) d :: 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 (m :: * -> *) a. Monad m => a -> m a
return ())

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