@@ -1,85 +0,0 @@
1−{-# LANGUAGE RecursiveDo, TypeFamilies, LambdaCase #-}
2−module Control.Monad.Ref where
3−
4−import Control.Monad
5−import Control.Monad.Trans
6−import Control.Monad.Reader
7−import Control.Monad.Writer
8−import Data.IORef
9−
10−class Monad m => MonadRef m where
11− type Ref m :: * -> *
12− newRef :: a -> m (Ref m a)
13− readRef :: Ref m a -> m a
14− writeRef :: Ref m a -> a -> m ()
15− atomicModifyRef :: Ref m a -> (a -> (a, b)) -> m b
16−
17−instance MonadRef IO where
18− type Ref IO = IORef
19− {-# INLINE newRef #-}
20− newRef = newIORef
21− {-# INLINE readRef #-}
22− readRef = readIORef
23− {-# INLINE writeRef #-}
24− writeRef = writeIORef
25− {-# INLINE atomicModifyRef #-}
26− atomicModifyRef r f = do
27− result <- atomicModifyIORef' r f
28−-- evaluate =<< readIORef r --TODO: Verify that ghcjs now strictly evaluates the values in atomicModifyIORef', then remove this line
29− return result
30−
31−{-# INLINE cacheM #-}
32−cacheM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m ())
33−cacheM a = do
34− r <- newRef undefined
35− let invalidate = writeRef r $ do
36− result <- a
37− writeRef r $ return result
38− return result
39− invalidate
40− return (join $ readRef r, invalidate)
41−
42−{-# INLINE cacheMWithTry #-}
43−cacheMWithTry :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m (Maybe a), m ())
44−cacheMWithTry a = do
45− r <- newRef $ Left a
46− let invalidate = writeRef r $ Left a
47− get = readRef r >>= \case
48− Left a' -> do
49− result <- a'
50− writeRef r $ Right result
51− return result
52− Right result -> return result
53− tryGet = readRef r >>= \case
54− Left _ -> return Nothing
55− Right result -> return $ Just result
56− return (get, tryGet, invalidate)
57−
58−-- | Not thread-safe or reentrant
59−{-# INLINE memoM #-}
60−memoM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a)
61−memoM = liftM fst . cacheM
62−
63−{-# INLINE replaceRef #-}
64−replaceRef :: MonadRef m => Ref m a -> a -> m a
65−replaceRef r new = atomicModifyRef r $ \old -> (new, old)
66−
67−{-# INLINE modifyRef #-}
68−modifyRef :: MonadRef m => Ref m a -> (a -> a) -> m ()
69−modifyRef r f = atomicModifyRef r $ \a -> (f a, ())
70−
71−instance (Monoid w, MonadRef m) => MonadRef (WriterT w m) where
72− {-# SPECIALIZE instance Monoid w => MonadRef (WriterT w IO) #-}
73− type Ref (WriterT w m) = Ref m
74− newRef = lift . newRef
75− readRef = lift . readRef
76− writeRef r = lift . writeRef r
77− atomicModifyRef r f = lift $ atomicModifyRef r f
78−
79−instance MonadRef m => MonadRef (ReaderT r m) where
80− {-# SPECIALIZE instance MonadRef (ReaderT r IO) #-}
81− type Ref (ReaderT r m) = Ref m
82− newRef = lift . newRef
83− readRef = lift . readRef
84− writeRef r = lift . writeRef r
85− atomicModifyRef r f = lift $ atomicModifyRef r f