{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, TypeOperators #-}
module Test.IOSpec.MVar
(
MVarS
, MVar
, newEmptyMVar
, takeMVar
, putMVar
)
where
import Data.Dynamic
import Data.Maybe (fromJust)
import Test.IOSpec.Types
import Test.IOSpec.VirtualMachine
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)
newtype MVar a = MVar Loc deriving Typeable
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 (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)
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 (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)
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 (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
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 Data -> a
t) = do Maybe Data
var <- Loc -> VM (Maybe Data)
lookupHeap Loc
loc
case Maybe Data
var of
Maybe Data
Nothing -> Step a -> VM (Step 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 -> 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 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
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 Data
_ -> Step a -> VM (Step a)
forall (m :: * -> *) a. Monad m => a -> m a
return Step a
forall a. Step a
Block