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