1{-# LANGUAGE 2 CPP, 3 MultiParamTypeClasses, 4 FlexibleInstances, 5 IncoherentInstances 6 #-} 7 8-- |This module exports no new symbols of its own. It defines 9-- basic class instances for creating, reading, and writing 'TVar's and 10-- (if available) 'TMVar's, and re-exports the types for which it defines 11-- instances as well as the 'atomically' function, which is indispensible 12-- when playing with this stuff in ghci. 13-- 14-- Note that this module declares incoherent instances. The universe should 15-- refrain from imploding on itself as long as you don't define 16-- \"instance MonadIO STM\". However, hugs doesn't seem to support 17-- overlapping instances, so I may have to give up on the dream of MonadIO 18-- everywhere, or introduce some major conditional compilation stuff. (or 19-- abandon hugs support) 20 21module Data.StateRef.Instances.STM 22 ( STM 23 , TVar 24#ifdef useTMVar 25 , TMVar 26#endif 27 28 , atomically 29 ) where 30 31import Data.StateRef.Types 32import Control.Monad.Trans 33import Control.Concurrent.STM 34 35-- (STM a) in STM and IO-compatible monads 36instance ReadRef (STM a) STM a where 37 readReference = id 38instance MonadIO m => ReadRef (STM a) m a where 39 readReference = liftIO . atomically 40 41-- TVar in STM monad 42instance HasRef STM where 43 newRef x = do 44 sr <- newTVar x 45 return (Ref sr) 46instance NewRef (TVar a) STM a where 47 newReference = newTVar 48instance ReadRef (TVar a) STM a where 49 readReference = readTVar 50instance WriteRef (TVar a) STM a where 51 writeReference = writeTVar 52instance ModifyRef (TVar a) STM a where 53 atomicModifyReference = defaultAtomicModifyReference 54 modifyReference = defaultModifyReference 55 56-- TVar in IO-compatible monads 57instance MonadIO m => NewRef (TVar a) m a where 58 newReference = liftIO . newTVarIO 59instance MonadIO m => ReadRef (TVar a) m a where 60 readReference = liftIO . atomically . readReference 61instance MonadIO m => WriteRef (TVar a) m a where 62 writeReference ref = liftIO . atomically . writeReference ref 63instance MonadIO m => ModifyRef (TVar a) m a where 64 modifyReference ref = liftIO . atomically . modifyReference ref 65 atomicModifyReference ref = liftIO . atomically . atomicModifyReference ref 66 67-- @Ref STM@ in IO-compatible monads 68instance MonadIO m => NewRef (Ref STM a) m a where 69 newReference x = do 70 sr <- liftIO (newTVarIO x) 71 return (Ref sr) 72instance MonadIO m => ReadRef (Ref STM a) m a where 73 readReference (Ref sr) = liftIO (atomically (readReference sr)) 74instance MonadIO m => WriteRef (Ref STM a) m a where 75 writeReference (Ref sr) = liftIO . atomically . writeReference sr 76instance MonadIO m => ModifyRef (Ref STM a) m a where 77 modifyReference (Ref sr) = liftIO . atomically . modifyReference sr 78 atomicModifyReference (Ref sr) = liftIO . atomically . atomicModifyReference sr 79 80#ifdef useTMVar 81-- TMVar in STM monad 82instance NewRef (TMVar a) STM (Maybe a) where 83 newReference Nothing = newEmptyTMVar 84 newReference (Just x) = newTMVar x 85instance ReadRef (TMVar a) STM (Maybe a) where 86 readReference tmv = fmap Just (readTMVar tmv) `orElse` return Nothing 87 88-- TMVar in IO-compatible monad 89instance MonadIO m => NewRef (TMVar a) m (Maybe a) where 90 newReference Nothing = liftIO newEmptyTMVarIO 91 newReference (Just x) = liftIO (newTMVarIO x) 92instance MonadIO m => ReadRef (TMVar a) m (Maybe a) where 93 readReference = liftIO . atomically . readReference 94#endif 95