public
Last active

  • Download Gist
ContextRef.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, RecursiveDo #-}
module ContextRefHidden
( ContextRef
, Context
, runContext
, newRef
, readRef
, writeRef
, refKey
, attempt
, save
) where
 
import Control.Monad.ST
import Control.Monad.State
 
import Data.Map
import Data.Maybe
import Data.IORef
 
import System.Mem.Weak
 
data ContextRef s a = ContextRef Int (IORef a)
deriving (Eq)
 
instance Ord (ContextRef s a) where
compare (ContextRef a _) (ContextRef b _) = compare a b
data ContextData s = ContextData [Int] (Map Int (IO (IO ())))
 
newtype Context s a = Context { unContext :: (StateT (IORef (ContextData s)) (ST s) a)}
deriving (Monad, MonadFix)
 
runContext :: (forall s. Context s a) -> a
runContext s = runST $ do
initialData <- newSTIORef $ ContextData [0..] empty
(a, _) <- runStateT (unContext s) initialData
return a
 
newRef :: a -> Context s (ContextRef s a)
newRef x = Context $ mdo
ref <- lift $ newSTIORef x
dataRef <- get
key <- lift $ unsafeIOToST $ atomicModifyIORef dataRef $
\(ContextData (nextKey:availableKeys) saveMap) -> (ContextData availableKeys (insert nextKey (saveIORef weakRef) saveMap), nextKey)
weakRef <- lift $ mkWeakSTIORef key dataRef ref
return $ ContextRef key ref
readRef :: ContextRef s a -> Context s a
readRef (ContextRef _ ref) = Context $ lift $ readSTIORef ref
 
writeRef :: ContextRef s a -> a -> Context s ()
writeRef (ContextRef _ ref) x = Context $ lift $ writeSTIORef ref x
 
refKey :: ContextRef s a -> Int
refKey (ContextRef key _) = key
 
-- any references made during the attempt will not get altered by the restore
attempt :: Context s (Either a b) -> Context s (Either a b)
attempt m = do
restore <- save
result <- m
when (isLeft result) restore
return result
save :: Context s (Context s ())
save = Context $ do
dataRef <- get
ContextData _ saveMap <- lift $ readSTIORef dataRef
restoreActions <- lift $ unsafeIOToST $ sequence $ elems saveMap
return ((Context $ lift $ unsafeIOToST $ sequence $ restoreActions) >> return ())
 
 
 
saveIORef :: Weak (IORef a) -> IO (IO ())
saveIORef weakRef = do
maybeRef <- deRefWeak weakRef
case maybeRef of
Just ref -> do
x <- readIORef ref
return (writeIORef ref x)
Nothing -> return (return ())
 
readSTIORef :: IORef a -> ST s a
readSTIORef x = unsafeIOToST $ readIORef x
 
newSTIORef :: a -> ST s (IORef a)
newSTIORef x = unsafeIOToST $ newIORef x
 
writeSTIORef :: IORef a -> a -> ST s ()
writeSTIORef ref x = unsafeIOToST $ writeIORef ref x
 
mkWeakSTIORef :: Int -> IORef (ContextData s) -> IORef a -> ST s (Weak (IORef a))
mkWeakSTIORef i dataRef ref = unsafeIOToST $ mkWeakIORef ref (atomicModifyIORef dataRef cleanUpRef)
where
cleanUpRef (ContextData is saveMap) = (ContextData (i:is) (delete i saveMap), ())
 
 
isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft _ = False

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.