module Updater.Internal (
Signal(),
newSignal,
getValue,
addListener,
Updater(),
onCommit,
getEvent,
getBehavior,
runUpdater,
liftSTM,
onCleanup
) where
import Control.Concurrent.STM
import qualified Updater.List as List
import Control.Applicative
import Control.Exception.Base
putLine :: String -> Updater ()
putLine = onCommit . putStrLn
data Signal a = Signal {
signalValue :: TVar (Maybe a),
signalListeners :: List.LinkedList (a -> Updater ())
}
newSignal :: STM (a -> Updater (), Signal a)
newSignal = do
value <- newTVar (Nothing)
listeners <- List.empty
let runSignal a = do
liftSTM $ writeTVar value $ Just a
listeners' <- liftSTM $ List.toList listeners
mapM_ ($ a) listeners'
return (runSignal,Signal value listeners)
getValue :: Signal a -> STM (Maybe a)
getValue signal = readTVar $ signalValue signal
addListener :: Signal a -> (a -> Updater ()) -> STM (STM ())
addListener signal listener = do
node <- List.append listener (signalListeners signal)
return (List.delete node)
data State = State {
stateOnCommit :: TVar (IO ()),
stateCleanup :: Signal ()
}
newtype Updater a = Updater { runUpdater' :: (a -> State -> STM ()) -> State -> STM () }
getCleanup :: Updater (Signal ())
getCleanup = fmap stateCleanup getState
onCleanup :: Updater () -> Updater ()
onCleanup cleanup = do
getCleanup >>= getEvent
cleanup
newCleanupHelper :: Signal () -> STM (Updater (Signal ()))
newCleanupHelper endSignal = do
(cleanupButton,cleanupSignal) <- newSignal
return $ do
cleanup' <- liftSTM $ getValue cleanupSignal
(innerCleanupButton, innerCleanupSignal) <- liftSTM $ newSignal
cleanupButton (innerCleanupButton ())
removeListener <- liftSTM $ addListener (endSignal) (innerCleanupButton)
_ <- liftSTM $ addListener innerCleanupSignal (const $ liftSTM removeListener)
case cleanup' of
Nothing -> return ()
(Just cleanup) -> cleanup
return innerCleanupSignal
onCommit :: IO () -> Updater ()
onCommit action = Updater $ \restCalc state -> do
modifyTVar (stateOnCommit state) (>>action)
restCalc () state
getState :: Updater State
getState = Updater $ \restCalc state -> restCalc state state
getEvent :: Signal a -> Updater a
getEvent signal = Updater $ \restCalc state-> do
cleanupHelper <- newCleanupHelper (stateCleanup state)
let listener value = do
innerCleanupSignal <- cleanupHelper
state' <-getState
liftSTM $ restCalc value (state' { stateCleanup = innerCleanupSignal })
return ()
removeListener <- addListener signal listener
_ <- addListener (stateCleanup state) (const $ liftSTM removeListener)
return ()
getBehavior :: Signal a -> Updater a
getBehavior sig = initial <|> getEvent sig where
initial = do
val' <- liftSTM $ getValue sig
case val' of
Nothing -> empty
(Just val) -> return val
runUpdater :: Updater a -> IO a
runUpdater updater' = wrapper where
wrapper = do
(cleanupButton, cleanupSignal) <- atomically $ newSignal
onException
(run updater' cleanupButton cleanupSignal)
(run (cleanupButton ()) cleanupButton cleanupSignal)
run updater cleanupButton cleanupSignal= do
(resultVar, onCommitAction) <- atomically $ do
onCommit' <- newTVar $ return ()
resultVar <- newEmptyTMVar
runUpdater'
( do
res <- updater
cleanupButton ()
onCommit $ atomically $ putTMVar resultVar res)
(const $ const $ return ())
(State {
stateCleanup = cleanupSignal,
stateOnCommit = onCommit' })
onCommitAction <- readTVar onCommit'
return (resultVar, onCommitAction)
onCommitAction
result <- atomically $ takeTMVar resultVar
return result
liftSTM :: STM a -> Updater a
liftSTM run = Updater (\restCalc state -> run >>= (\x -> restCalc x state))
instance Functor Updater where
fmap f (Updater giveMeNext) = Updater (\next -> giveMeNext (next . f))
instance Applicative Updater where
pure a = Updater $ \giveMeA -> giveMeA a
updater1 <*> updater2 = Updater $ updater where
updater restCalc state = do
(buttonF, signalF) <- newSignal
(buttonX, signalX) <- newSignal
cleanupHelper <- newCleanupHelper (stateCleanup state)
let fire = do
cleanupSignal <- cleanupHelper
f' <- liftSTM $ getValue signalF
x' <- liftSTM $ getValue signalX
case (f',x') of
(Just f, Just a) -> do
state' <- getState
liftSTM $ restCalc (f a) (state' { stateCleanup = cleanupSignal })
_ -> return ()
runUpdater' (updater1 >>= buttonF >> fire) (const $ const $ return ()) state
runUpdater' (updater2 >>= buttonX >> fire) (const $ const $ return ()) state
return ()
instance Alternative Updater where
empty = Updater $ const $ const $ return ()
updater1 <|> updater2 = Updater $ updater where
updater end state = do
(button,signal) <-newSignal
cleanupHelper <- newCleanupHelper (stateCleanup state)
let fire = do
cleanupSignal <- cleanupHelper
value' <- liftSTM $ getValue signal
case value' of
(Just value) -> do
state' <- getState
liftSTM $ end value (state' { stateCleanup = cleanupSignal })
Nothing -> return ()
runUpdater' (updater1 >>= button >> fire) (const $ const $ return ()) state
runUpdater' (updater2 >>= button >> fire) (const $ const $ return ()) state
return ()
instance Monad Updater where
(Updater giveMeNext) >>= valueToNextUpd = Updater $ updater where
updater end = giveMeNext $ \value -> runUpdater' (valueToNextUpd value) end
return a = Updater $ \end -> end a