module Test.IOSpec.IORef
(
IOState
, runIOState
, IORef
, newIORef
, readIORef
, writeIORef
, modifyIORef
)
where
import Control.Monad.State
import Data.Dynamic
import Data.Maybe (fromJust)
type Data = Dynamic
type Loc = Int
data IOState a =
NewIORef Data (Loc -> IOState a)
| ReadIORef Loc (Data -> IOState a)
| WriteIORef Loc Data (IOState a)
| Return a
instance Functor IOState where
fmap f (NewIORef d io) = NewIORef d (\l -> fmap f (io l))
fmap f (ReadIORef l io) = ReadIORef l (\d -> fmap f (io d))
fmap f (WriteIORef l d io) = WriteIORef l d (fmap f io)
fmap f (Return x) = Return (f x)
instance Monad IOState where
return = Return
(Return a) >>= g = g a
(NewIORef d f) >>= g = NewIORef d (\l -> f l >>= g)
(ReadIORef l f) >>= g = ReadIORef l (\d -> f d >>= g)
(WriteIORef l d s) >>= g = WriteIORef l d (s >>= g)
newtype IORef a = IORef Loc
newIORef :: Typeable a => a -> IOState (IORef a)
newIORef d = NewIORef (toDyn d) (Return . IORef)
readIORef :: Typeable a => IORef a -> IOState a
readIORef (IORef l) = ReadIORef l (Return . unsafeFromDynamic)
writeIORef :: Typeable a => IORef a -> a -> IOState ()
writeIORef (IORef l) d = WriteIORef l (toDyn d) (Return ())
modifyIORef :: Typeable a => IORef a -> (a -> a) -> IOState ()
modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x)
unsafeFromDynamic :: Typeable a => Dynamic -> a
unsafeFromDynamic = fromJust . fromDynamic
data Store = Store {fresh :: Loc, heap :: Heap}
type Heap = Loc -> Data
emptyStore :: Store
emptyStore = Store {fresh = 0}
runIOState :: IOState a -> a
runIOState io = evalState (step io) emptyStore
step :: IOState a -> State Store a
step (Return a) = return a
step (NewIORef d g)
= do loc <- alloc
extendHeap loc d
step (g loc)
step (ReadIORef l g)
= do d <- lookupHeap l
step (g d)
step (WriteIORef l d p)
= do extendHeap l d
step p
alloc :: State Store Loc
alloc = do loc <- gets fresh
modifyFresh ((+) 1)
return loc
lookupHeap :: Loc -> State Store Data
lookupHeap l = do h <- gets heap
return (h l)
extendHeap :: Loc -> Data -> State Store ()
extendHeap l d = modifyHeap (update l d)
modifyHeap :: (Heap -> Heap) -> State Store ()
modifyHeap f = do s <- get
put (s {heap = f (heap s)})
modifyFresh :: (Loc -> Loc) -> State Store ()
modifyFresh f = do s <- get
put (s {fresh = f (fresh s)})
update :: Loc -> Data -> Heap -> Heap
update l d h k
| l == k = d
| otherwise = h k