{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
#if USE_DEFAULT_SIGNATURES
{-# LANGUAGE DefaultSignatures #-}
#endif
{-# LANGUAGE TypeFamilies #-}
#if __GLASGOW_HASKELL__ >= 704 && MIN_VERSION_base(4,8,0)
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module Data.StateVar
(
HasGetter(get)
, GettableStateVar, makeGettableStateVar
, HasSetter(($=)), ($=!)
, SettableStateVar(SettableStateVar), makeSettableStateVar
, HasUpdate(($~), ($~!))
, StateVar(StateVar), makeStateVar
, mapStateVar
) where
import Control.Concurrent.STM
import Control.Monad.IO.Class
import Data.IORef
import Data.Typeable
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif
data StateVar a = StateVar (IO a) (a -> IO ()) deriving Typeable
#if MIN_VERSION_base(4,12,0)
instance Contravariant SettableStateVar where
contramap :: forall a' a. (a' -> a) -> SettableStateVar a -> SettableStateVar a'
contramap a' -> a
f (SettableStateVar a -> IO ()
k) = (a' -> IO ()) -> SettableStateVar a'
forall a. (a -> IO ()) -> SettableStateVar a
SettableStateVar (a -> IO ()
k (a -> IO ()) -> (a' -> a) -> a' -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)
{-# INLINE contramap #-}
#endif
makeStateVar
:: IO a
-> (a -> IO ())
-> StateVar a
makeStateVar :: forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar = IO a -> (a -> IO ()) -> StateVar a
forall a. IO a -> (a -> IO ()) -> StateVar a
StateVar
mapStateVar :: (b -> a) -> (a -> b) -> StateVar a -> StateVar b
mapStateVar :: forall b a. (b -> a) -> (a -> b) -> StateVar a -> StateVar b
mapStateVar b -> a
ba a -> b
ab (StateVar IO a
ga a -> IO ()
sa) = IO b -> (b -> IO ()) -> StateVar b
forall a. IO a -> (a -> IO ()) -> StateVar a
StateVar ((a -> b) -> IO a -> IO b
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ab IO a
ga) (a -> IO ()
sa (a -> IO ()) -> (b -> a) -> b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
ba)
{-# INLINE mapStateVar #-}
newtype SettableStateVar a = SettableStateVar (a -> IO ())
deriving Typeable
makeSettableStateVar
:: (a -> IO ())
-> SettableStateVar a
makeSettableStateVar :: forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar = (a -> IO ()) -> SettableStateVar a
forall a. (a -> IO ()) -> SettableStateVar a
SettableStateVar
{-# INLINE makeSettableStateVar #-}
type GettableStateVar = IO
makeGettableStateVar
:: IO a
-> GettableStateVar a
makeGettableStateVar :: forall a. IO a -> IO a
makeGettableStateVar = IO a -> IO a
forall a. a -> a
id
{-# INLINE makeGettableStateVar #-}
infixr 2 $=, $=!
class HasSetter t a | t -> a where
($=) :: MonadIO m => t -> a -> m ()
($=!) :: (HasSetter t a, MonadIO m) => t -> a -> m ()
t
p $=! :: forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$=! a
a = (t
p t -> a -> m ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *). MonadIO m => t -> a -> m ()
$=) (a -> m ()) -> a -> m ()
forall a b. (a -> b) -> a -> b
$! a
a
{-# INLINE ($=!) #-}
instance HasSetter (SettableStateVar a) a where
SettableStateVar a -> IO ()
f $= :: forall (m :: * -> *). MonadIO m => SettableStateVar a -> a -> m ()
$= a
a = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO ()
f a
a)
{-# INLINE ($=) #-}
instance HasSetter (StateVar a) a where
StateVar IO a
_ a -> IO ()
s $= :: forall (m :: * -> *). MonadIO m => StateVar a -> a -> m ()
$= a
a = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ a -> IO ()
s a
a
{-# INLINE ($=) #-}
instance Storable a => HasSetter (Ptr a) a where
Ptr a
p $= :: forall (m :: * -> *). MonadIO m => Ptr a -> a -> m ()
$= a
a = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
p a
a
{-# INLINE ($=) #-}
instance HasSetter (IORef a) a where
IORef a
p $= :: forall (m :: * -> *). MonadIO m => IORef a -> a -> m ()
$= a
a = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
p a
a
{-# INLINE ($=) #-}
instance HasSetter (TVar a) a where
TVar a
p $= :: forall (m :: * -> *). MonadIO m => TVar a -> a -> m ()
$= a
a = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
p a
a
{-# INLINE ($=) #-}
instance Storable a => HasSetter (ForeignPtr a) a where
ForeignPtr a
p $= :: forall (m :: * -> *). MonadIO m => ForeignPtr a -> a -> m ()
$= a
a = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
p (Ptr a -> a -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *). MonadIO m => Ptr a -> a -> m ()
$= a
a)
{-# INLINE ($=) #-}
infixr 2 $~, $~!
class HasSetter t b => HasUpdate t a b | t -> a b where
($~) :: MonadIO m => t -> (a -> b) -> m ()
#if USE_DEFAULT_SIGNATURES
default ($~) :: (MonadIO m, a ~ b, HasGetter t a) => t -> (a -> b) -> m ()
($~) = t -> (a -> b) -> m ()
forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdate
#endif
($~!) :: MonadIO m => t -> (a -> b) -> m ()
#if USE_DEFAULT_SIGNATURES
default ($~!) :: (MonadIO m, a ~ b, HasGetter t a) => t -> (a -> b) -> m ()
($~!) = t -> (a -> b) -> m ()
forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdateStrict
#endif
defaultUpdate :: (MonadIO m, a ~ b, HasGetter t a, HasSetter t a) => t -> (a -> b) -> m ()
defaultUpdate :: forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdate t
r a -> b
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
a
a <- t -> IO a
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => t -> m a
get t
r
t
r t -> b -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *). MonadIO m => t -> b -> m ()
$= a -> b
f a
a
defaultUpdateStrict :: (MonadIO m, a ~ b, HasGetter t a, HasSetter t a) => t -> (a -> b) -> m ()
defaultUpdateStrict :: forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdateStrict t
r a -> b
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
a
a <- t -> IO a
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => t -> m a
get t
r
t
r t -> b -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$=! a -> b
f a
a
instance HasUpdate (StateVar a) a a where
$~ :: forall (m :: * -> *). MonadIO m => StateVar a -> (a -> a) -> m ()
($~) = StateVar a -> (a -> a) -> m ()
forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdate
$~! :: forall (m :: * -> *). MonadIO m => StateVar a -> (a -> a) -> m ()
($~!) = StateVar a -> (a -> a) -> m ()
forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdateStrict
instance Storable a => HasUpdate (Ptr a) a a where
$~ :: forall (m :: * -> *). MonadIO m => Ptr a -> (a -> a) -> m ()
($~) = Ptr a -> (a -> a) -> m ()
forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdate
$~! :: forall (m :: * -> *). MonadIO m => Ptr a -> (a -> a) -> m ()
($~!) = Ptr a -> (a -> a) -> m ()
forall (m :: * -> *) a b t.
(MonadIO m, a ~ b, HasGetter t a, HasSetter t a) =>
t -> (a -> b) -> m ()
defaultUpdateStrict
instance HasUpdate (IORef a) a a where
IORef a
r $~ :: forall (m :: * -> *). MonadIO m => IORef a -> (a -> a) -> m ()
$~ a -> a
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef a -> (a -> (a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
r ((a -> (a, ())) -> IO ()) -> (a -> (a, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \a
a -> (a -> a
f a
a,())
#if MIN_VERSION_base(4,6,0)
IORef a
r $~! :: forall (m :: * -> *). MonadIO m => IORef a -> (a -> a) -> m ()
$~! a -> a
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef a -> (a -> (a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef a
r ((a -> (a, ())) -> IO ()) -> (a -> (a, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \a
a -> (a -> a
f a
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
TVar a
r $~ :: forall (m :: * -> *). MonadIO m => TVar a -> (a -> a) -> m ()
$~ a -> a
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
a
a <- TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
r
TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
r (a -> a
f a
a)
TVar a
r $~! :: forall (m :: * -> *). MonadIO m => TVar a -> (a -> a) -> m ()
$~! a -> a
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
a
a <- TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
r
TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
r (a -> STM ()) -> a -> STM ()
forall a b. (a -> b) -> a -> b
$! a -> a
f a
a
instance Storable a => HasUpdate (ForeignPtr a) a a where
ForeignPtr a
p $~ :: forall (m :: * -> *). MonadIO m => ForeignPtr a -> (a -> a) -> m ()
$~ a -> a
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
p (Ptr a -> (a -> a) -> IO ()
forall t a b (m :: * -> *).
(HasUpdate t a b, MonadIO m) =>
t -> (a -> b) -> m ()
forall (m :: * -> *). MonadIO m => Ptr a -> (a -> a) -> m ()
$~ a -> a
f)
ForeignPtr a
p $~! :: forall (m :: * -> *). MonadIO m => ForeignPtr a -> (a -> a) -> m ()
$~! a -> a
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
p (Ptr a -> (a -> a) -> IO ()
forall t a b (m :: * -> *).
(HasUpdate t a b, MonadIO m) =>
t -> (a -> b) -> m ()
forall (m :: * -> *). MonadIO m => Ptr a -> (a -> a) -> m ()
$~! a -> a
f)
class HasGetter t a | t -> a where
get :: MonadIO m => t -> m a
instance HasGetter (StateVar a) a where
get :: forall (m :: * -> *). MonadIO m => StateVar a -> m a
get (StateVar IO a
g a -> IO ()
_) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
g
{-# INLINE get #-}
instance HasGetter (TVar a) a where
get :: forall (m :: * -> *). MonadIO m => TVar a -> m a
get = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (TVar a -> IO a) -> TVar a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> (TVar a -> STM a) -> TVar a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> STM a
forall a. TVar a -> STM a
readTVar
{-# INLINE get #-}
instance HasGetter (IO a) a where
get :: forall (m :: * -> *). MonadIO m => IO a -> m a
get = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE get #-}
instance HasGetter (STM a) a where
get :: forall (m :: * -> *). MonadIO m => STM a -> m a
get = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (STM a -> IO a) -> STM a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically
{-# INLINE get #-}
instance Storable a => HasGetter (Ptr a) a where
get :: forall (m :: * -> *). MonadIO m => Ptr a -> m a
get = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (Ptr a -> IO a) -> Ptr a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek
{-# INLINE get #-}
instance HasGetter (IORef a) a where
get :: forall (m :: * -> *). MonadIO m => IORef a -> m a
get = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (IORef a -> IO a) -> IORef a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef a -> IO a
forall a. IORef a -> IO a
readIORef
{-# INLINE get #-}
instance Storable a => HasGetter (ForeignPtr a) a where
get :: forall (m :: * -> *). MonadIO m => ForeignPtr a -> m a
get ForeignPtr a
p = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
p Ptr a -> IO a
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => Ptr a -> m a
get
{-# INLINE get #-}