{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RecordWildCards #-}
module Reflex.ExternalRef(
ExternalRef(..)
, newExternalRef
, readExternalRef
, writeExternalRef
, modifyExternalRef
, modifyExternalRef_
, modifyExternalRefMaybe
, modifyExternalRefMaybe_
, modifyExternalRefM
, modifyExternalRefM_
, modifyExternalRefMaybeM
, modifyExternalRefMaybeM_
, externalRefBehavior
, externalRefDynamic
, externalFromDynamic
, fmapExternalRef
) where
import Control.DeepSeq
import Control.Monad.IO.Class
import Data.IORef
import GHC.Generics
import Reflex
data ExternalRef t a = ExternalRef {
externalRef :: !(IORef a)
, externalEvent :: !(Event t a)
, externalFire :: !(a -> IO ())
} deriving (Generic)
instance NFData (ExternalRef t a) where
rnf ExternalRef{..} =
externalRef `deepseq`
externalEvent `seq`
externalFire `seq`
()
newExternalRef :: (MonadIO m, TriggerEvent t m) => a -> m (ExternalRef t a)
newExternalRef a = do
ref <- liftIO $ newIORef a
(e, fire) <- newTriggerEvent
return $ ExternalRef ref e fire
readExternalRef :: MonadIO m => ExternalRef t a -> m a
readExternalRef ExternalRef {..} = liftIO $ readIORef externalRef
writeExternalRef :: MonadIO m => ExternalRef t a -> a -> m ()
writeExternalRef ExternalRef {..} a = do
a `seq` liftIO (writeIORef externalRef a)
_ <- liftIO $ externalFire a
return ()
modifyExternalRef :: MonadIO m => ExternalRef t a -> (a -> (a, b)) -> m b
modifyExternalRef ExternalRef {..} f = do
(a, b) <- liftIO $ atomicModifyIORef' externalRef $ \a ->
let (a', b) = f a in (a', (a', b))
_ <- liftIO $ externalFire a
return b
modifyExternalRef_ :: MonadIO m => ExternalRef t a -> (a -> a) -> m ()
modifyExternalRef_ ExternalRef {..} f = do
a <- liftIO $ atomicModifyIORef' externalRef $ \a ->
let a' = f a in (a', a')
liftIO $ externalFire a
modifyExternalRefMaybe :: MonadIO m => ExternalRef t a -> (a -> Maybe (a,b)) -> m (Maybe b)
modifyExternalRefMaybe ExternalRef {..} f = do
mab <- liftIO $ atomicModifyIORef' externalRef $ \a ->
maybe (a, Nothing) (\ab-> (fst ab, Just ab)) $ f a
liftIO $ maybe (pure ()) (externalFire . fst) mab
pure $ snd <$> mab
modifyExternalRefMaybe_ :: MonadIO m => ExternalRef t a -> (a -> Maybe a) -> m ()
modifyExternalRefMaybe_ ExternalRef {..} f = do
ma <- liftIO $ atomicModifyIORef' externalRef $ \a ->
maybe (a, Nothing) (\a' -> (a', Just a')) $ f a
liftIO $ maybe (pure ()) externalFire ma
modifyExternalRefM :: MonadIO m => ExternalRef t a -> (a -> m (a, b)) -> m b
modifyExternalRefM ExternalRef {..} f = do
a <- liftIO $ readIORef externalRef
(a', b) <- f a
liftIO $ do
writeIORef externalRef a'
externalFire a'
return b
modifyExternalRefM_ :: MonadIO m => ExternalRef t a -> (a -> m a) -> m ()
modifyExternalRefM_ ExternalRef {..} f = do
a <- liftIO $ readIORef externalRef
a' <- f a
liftIO $ do
writeIORef externalRef a'
externalFire a'
modifyExternalRefMaybeM :: MonadIO m => ExternalRef t a -> (a -> m (Maybe (a, b))) -> m (Maybe b)
modifyExternalRefMaybeM ExternalRef {..} f = do
a <- liftIO $ readIORef externalRef
mab <- f a
case mab of
Nothing -> pure Nothing
Just (a',b) -> liftIO $ do
writeIORef externalRef a'
externalFire a'
return $ Just b
modifyExternalRefMaybeM_ :: MonadIO m => ExternalRef t a -> (a -> m (Maybe a)) -> m ()
modifyExternalRefMaybeM_ ExternalRef {..} f = do
a <- liftIO $ readIORef externalRef
ma <- f a
case ma of
Nothing -> pure ()
Just a' -> liftIO $ do
writeIORef externalRef a'
externalFire a'
externalRefBehavior :: (MonadHold t m, MonadIO m) => ExternalRef t a -> m (Behavior t a)
externalRefBehavior ExternalRef {..} = do
a <- liftIO $ readIORef externalRef
hold a externalEvent
externalRefDynamic :: (MonadHold t m, MonadIO m) => ExternalRef t a -> m (Dynamic t a)
externalRefDynamic ExternalRef {..} = do
a <- liftIO $ readIORef externalRef
holdDyn a externalEvent
externalFromDynamic :: (MonadHold t m, TriggerEvent t m, PerformEvent t m, Reflex t, MonadIO m, MonadIO (Performable m))
=> Dynamic t a -> m (ExternalRef t a)
externalFromDynamic da = do
a0 <- sample . current $ da
r <- newExternalRef a0
performEvent_ $ fmap (writeExternalRef r) $ updated da
pure r
fmapExternalRef :: (MonadIO m, TriggerEvent t m, PerformEvent t m, MonadIO (Performable m))
=> (a -> b) -> ExternalRef t a -> m (ExternalRef t b)
fmapExternalRef f ea = do
v0 <- readExternalRef ea
r <- newExternalRef $ f v0
performEvent_ $ fmap (writeExternalRef r . f) $ externalEvent ea
pure r