module Foreign.Var
(
Var(Var)
, mapVar
, SettableVar(SettableVar)
, GettableVar
, HasSetter(($=)), ($=!)
, HasUpdate(($~), ($~!))
, HasGetter(get)
) where
import Control.Concurrent.STM
import Control.Monad.IO.Class
import Data.Functor
import Data.IORef
import Data.Typeable
import Foreign.Ptr
import Foreign.Storable
data Var a = Var (IO a) (a -> IO ()) deriving Typeable
mapVar :: (b -> a) -> (a -> b) -> Var a -> Var b
mapVar ba ab (Var ga sa) = Var (ab <$> ga) (sa . ba)
newtype SettableVar a = SettableVar (a -> IO ())
deriving Typeable
type GettableVar = IO
infixr 2 $=, $=!
class HasSetter t a | t -> a where
($=) :: MonadIO m => t -> a -> m ()
($=!) :: (HasSetter t a, MonadIO m) => t -> a -> m ()
p $=! a = (p $=) $! a
instance HasSetter (SettableVar a) a where
SettableVar f $= a = liftIO (f a)
instance HasSetter (Var a) a where
Var _ s $= a = liftIO $ s a
instance Storable a => HasSetter (Ptr a) a where
p $= a = liftIO $ poke p a
instance HasSetter (IORef a) a where
p $= a = liftIO $ writeIORef p a
instance HasSetter (TVar a) a where
p $= a = liftIO $ atomically $ writeTVar p a
infixr 2 $~, $~!
class HasSetter t a => HasUpdate t a b | t -> a b where
($~) :: MonadIO m => t -> (a -> b) -> m ()
default ($~) :: (MonadIO m, a ~ b, HasGetter t a, HasSetter t a) => t -> (a -> b) -> m ()
r $~ f = liftIO $ do
a <- get r
r $= f a
($~!) :: MonadIO m => t -> (a -> b) -> m ()
default ($~!) :: (MonadIO m, a ~ b, HasGetter t a, HasSetter t a) => t -> (a -> b) -> m ()
r $~! f = liftIO $ do
a <- get r
r $=! f a
instance HasUpdate (Var a) a a
instance Storable a => HasUpdate (Ptr a) a a
instance HasUpdate (IORef a) a a where
r $~ f = liftIO $ atomicModifyIORef r $ \a -> (f a,())
#if __GLASGOW_HASKELL__ >= 706
r $~! f = liftIO $ atomicModifyIORef' r $ \a -> (f a,())
#else
r $~! f = liftIO $ do
s <- atomicModifyIORef r $ \a -> let s = f a in (s, s)
s `seq` return ()
#endif
instance HasUpdate (TVar a) a a where
r $~ f = liftIO $ atomically $ do
a <- readTVar r
writeTVar r (f a)
r $~! f = liftIO $ atomically $ do
a <- readTVar r
writeTVar r $! f a
class HasGetter t a | t -> a where
get :: MonadIO m => t -> m a
instance HasGetter (Var a) a where
get (Var g _) = liftIO g
instance HasGetter (TVar a) a where
get = liftIO . atomically . readTVar
instance HasGetter (IO a) a where
get = liftIO
instance HasGetter (STM a) a where
get = liftIO . atomically
instance Storable a => HasGetter (Ptr a) a where
get = liftIO . peek
instance HasGetter (IORef a) a where
get = liftIO . readIORef