module Lava.Ref
( Ref
, ref
, deref
, memoRef
, TableIO
, tableIO
, extendIO
, findIO
, memoRefIO
, TableST
, tableST
, extendST
, findST
, memoRefST
)
where
import Lava.MyST
import System.IO
import System.IO.Unsafe
import Data.IORef
unsafeCoerce :: a -> b
unsafeCoerce a = unsafePerformIO $
do writeIORef ref a
readIORef ref
where
ref = unsafePerformIO $ newIORef undefined
data Ref a
= Ref (IORef [(TableTag, Dyn)]) a
instance Eq (Ref a) where
Ref r1 _ == Ref r2 _ = r1 == r2
instance Show a => Show (Ref a) where
showsPrec _ (Ref _ a) = showChar '{' . shows a . showChar '}'
ref :: a -> Ref a
ref a = unsafePerformIO $
do r <- newIORef []
return (Ref r a)
deref :: Ref a -> a
deref (Ref _ a) = a
type TableTag
= IORef ()
newtype TableIO a b
= TableIO TableTag
deriving Eq
tableIO :: IO (TableIO a b)
tableIO = TableIO `fmap` newIORef ()
findIO :: TableIO a b -> Ref a -> IO (Maybe b)
findIO (TableIO t) (Ref r _) =
do list <- readIORef r
return (fromDyn `fmap` lookup t list)
extendIO :: TableIO a b -> Ref a -> b -> IO ()
extendIO (TableIO t) (Ref r _) b =
do list <- readIORef r
writeIORef r ((t,toDyn b) : filter ((/= t) . fst) list)
newtype TableST s a b
= TableST (TableIO a b)
deriving Eq
tableST :: ST s (TableST s a b)
tableST = unsafeIOtoST (TableST `fmap` tableIO)
findST :: TableST s a b -> Ref a -> ST s (Maybe b)
findST (TableST tab) r = unsafeIOtoST (findIO tab r)
extendST :: TableST s a b -> Ref a -> b -> ST s ()
extendST (TableST tab) r b = unsafeIOtoST (extendIO tab r b)
memoRef :: (Ref a -> b) -> (Ref a -> b)
memoRef f = unsafePerformIO . memoRefIO (return . f)
memoRefIO :: (Ref a -> IO b) -> (Ref a -> IO b)
memoRefIO f = unsafePerformIO $
do tab <- tableIO
let f' r = do mb <- findIO tab r
case mb of
Just b -> do return b
Nothing -> fixIO $ \b ->
do extendIO tab r b
f r
return f'
memoRefST :: (Ref a -> ST s b) -> (Ref a -> ST s b)
memoRefST f = unsafePerformST $
do tab <- tableST
let f' r = do mb <- findST tab r
case mb of
Just b -> do return b
Nothing -> fixST $ \b ->
do extendST tab r b
f r
return f'
data Dyn
= Dyn
toDyn :: a -> Dyn
toDyn = unsafeCoerce
fromDyn :: Dyn -> a
fromDyn = unsafeCoerce