{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BlockArguments #-}
module Control.Concurrent.STM.Incremental
( Mutability(Immutable, Mutable)
, Incremental
, incremental
, observe
, set
, setEq
, map
, mapEq
, combine
, combineEq
, choose
, chooseEq
, immutable
, onUpdate
, history
) where
import Prelude hiding (read, map)
import Data.Bool (bool)
import Control.Concurrent.STM
import Control.Monad (when)
data Mutability = Immutable | Mutable
data Incremental (mutability :: Mutability) a = Incremental
{ ref :: TVar a
, updateRef :: TVar (a -> STM ())
}
incremental :: a -> STM (Incremental 'Mutable a)
incremental a = do
ref <- newTVar a
Incremental ref <$> newTVar (const (pure ()))
map :: (a -> b) -> Incremental m a -> STM (Incremental 'Immutable b)
map f (Incremental ref updateRef) = do
newRef <- readTVar ref >>= newTVar . f
newUpdateRef <- newTVar (const (pure ()))
update <- readTVar updateRef
writeTVar updateRef \a -> do
update a
let b = f a
writeTVar newRef b
newUpdate <- readTVar newUpdateRef
newUpdate b
pure (Incremental newRef newUpdateRef)
mapEq :: Eq b => (a -> b) -> Incremental m a -> STM (Incremental 'Immutable b)
mapEq f (Incremental ref updateRef) = do
newRef <- readTVar ref >>= newTVar . f
newUpdateRef <- newTVar (const (pure ()))
update <- readTVar updateRef
writeTVar updateRef \a -> do
update a
b <- readTVar newRef
let b' = f a
when (b /= b') do
writeTVar newRef b'
newUpdate <- readTVar newUpdateRef
newUpdate b'
pure (Incremental newRef newUpdateRef)
set :: Incremental 'Mutable a -> a -> STM ()
set incr a = do
writeTVar (ref incr) a
update <- readTVar (updateRef incr)
update a
setEq :: Eq a => Incremental 'Mutable a -> a -> STM ()
setEq incr a = do
a' <- readTVar (ref incr)
when (a' /= a) do
writeTVar (ref incr) a
update <- readTVar (updateRef incr)
update a
observe :: Incremental m a -> STM a
observe = readTVar . ref
combine :: (a -> b -> c) -> Incremental m a -> Incremental m' b -> STM (Incremental 'Immutable c)
combine f (Incremental ref updateRef) (Incremental ref' updateRef') = do
a <- readTVar ref
b <- readTVar ref'
newRef <- newTVar (f a b)
newUpdateRef <- newTVar (const (pure ()))
update <- readTVar updateRef
update' <- readTVar updateRef'
writeTVar updateRef \a -> do
update a
b <- readTVar ref'
let c = f a b
writeTVar newRef c
newUpdate <- readTVar newUpdateRef
newUpdate c
writeTVar updateRef' \b -> do
update' b
a <- readTVar ref
let c = f a b
writeTVar newRef c
newUpdate <- readTVar newUpdateRef
newUpdate c
pure (Incremental newRef newUpdateRef)
combineEq :: Eq c => (a -> b -> c) -> Incremental m a -> Incremental m' b -> STM (Incremental 'Immutable c)
combineEq f (Incremental ref updateRef) (Incremental ref' updateRef') = do
a <- readTVar ref
b <- readTVar ref'
newRef <- newTVar (f a b)
newUpdateRef <- newTVar (const (pure ()))
update <- readTVar updateRef
update' <- readTVar updateRef'
writeTVar updateRef \a -> do
update a
b <- readTVar ref'
c <- readTVar newRef
let c' = f a b
when (c /= c') do
writeTVar newRef c'
newUpdate <- readTVar newUpdateRef
newUpdate c'
writeTVar updateRef' \b -> do
update' b
a <- readTVar ref
c <- readTVar newRef
let c' = f a b
when (c /= c') do
writeTVar newRef c'
newUpdate <- readTVar newUpdateRef
newUpdate c'
pure (Incremental newRef newUpdateRef)
immutable :: Incremental 'Mutable b -> Incremental 'Immutable b
immutable Incremental{..} = Incremental{..}
choose :: Incremental m' a -> (a -> Incremental m b) -> STM (Incremental 'Immutable b)
choose (Incremental ref updateRef) f = do
a <- readTVar ref
let Incremental ref' updateRef' = f a
newRef <- readTVar ref' >>= newTVar
newUpdateRef <- newTVar (const (pure ()))
update' <- readTVar updateRef'
update <- readTVar updateRef
updateFromWhichRef <- newTVar (ref', [ref'])
writeTVar updateRef' \b -> do
update' b
(tvar, _tvars) <- readTVar updateFromWhichRef
when (tvar == ref') do
writeTVar newRef b
newUpdate <- readTVar newUpdateRef
newUpdate b
writeTVar updateRef \a -> do
update a
(currentRef, pastRefs) <- readTVar updateFromWhichRef
let Incremental ref'' updateRef'' = f a
when (ref'' /= currentRef) do
b <- readTVar ref''
writeTVar newRef b
newUpdate <- readTVar newUpdateRef
newUpdate b
if not (ref'' `elem` pastRefs) then do
update'' <- readTVar updateRef''
writeTVar updateRef'' \b -> do
update'' b
(tvar, _tvars) <- readTVar updateFromWhichRef
when (tvar == ref'') do
writeTVar newRef b
newUpdate <- readTVar newUpdateRef
newUpdate b
writeTVar updateFromWhichRef (ref'', ref'' : pastRefs)
else writeTVar updateFromWhichRef (ref'', pastRefs)
pure (Incremental newRef newUpdateRef)
chooseEq :: Eq b => Incremental m' a -> (a -> Incremental m b) -> STM (Incremental 'Immutable b)
chooseEq (Incremental ref updateRef) f = do
a <- readTVar ref
let Incremental ref' updateRef' = f a
newRef <- readTVar ref' >>= newTVar
newUpdateRef <- newTVar (const (pure ()))
update' <- readTVar updateRef'
update <- readTVar updateRef
updateFromWhichRef <- newTVar (ref', [ref'])
writeTVar updateRef' \b -> do
update' b
(tvar, _tvars) <- readTVar updateFromWhichRef
when (tvar == ref') do
b' <- readTVar newRef
when (b' /= b) do
writeTVar newRef b
newUpdate <- readTVar newUpdateRef
newUpdate b
writeTVar updateRef \a -> do
update a
(currentRef, pastRefs) <- readTVar updateFromWhichRef
let Incremental ref'' updateRef'' = f a
when (ref'' /= currentRef) do
b <- readTVar ref''
writeTVar newRef b
newUpdate <- readTVar newUpdateRef
newUpdate b
if not (ref'' `elem` pastRefs) then do
update'' <- readTVar updateRef''
writeTVar updateRef'' \b -> do
update'' b
(tvar, _tvars) <- readTVar updateFromWhichRef
when (tvar == ref'') do
b' <- readTVar newRef
when (b' /= b) do
writeTVar newRef b
newUpdate <- readTVar newUpdateRef
newUpdate b
writeTVar updateFromWhichRef (ref'', ref'' : pastRefs)
else writeTVar updateFromWhichRef (ref'', pastRefs)
pure (Incremental newRef newUpdateRef)
onUpdate :: Incremental m b -> (b -> STM ()) -> STM ()
onUpdate (Incremental _ref updateRef) monitoring = do
update <- readTVar updateRef
writeTVar updateRef \b -> do
update b
monitoring b
history :: Incremental m b -> STM (STM [b])
history i = do
x <- observe i
h <- newTVar [x]
onUpdate i \b -> do
bs <- readTVar h
writeTVar h (b : bs)
pure (readTVar h)