diff --git a/Updater.cabal b/Updater.cabal --- a/Updater.cabal +++ b/Updater.cabal @@ -1,5 +1,5 @@ Name: Updater -Version: 0.1 +Version: 0.2 Cabal-Version: >= 1.6 License: Apache-2.0 License-File: LICENSE @@ -13,10 +13,13 @@ Library Build-Depends: base >= 3 && < 5, stm + ghc-options: -Wall -fno-warn-tabs Exposed-Modules: Updater + Other-Modules: + Updater.List, Updater.Internal source-repository this type: git location: https://github.com/yokto/Updater.git - tag: 0.1 + tag: 0.2 diff --git a/Updater.hs b/Updater.hs --- a/Updater.hs +++ b/Updater.hs @@ -3,7 +3,9 @@ -- * Signals Signal(), newSignal, - getValue, + newSignalIO, + writeSignal, + readSignal, -- addListener, -- * Updater Monad Updater(), @@ -13,19 +15,26 @@ onCleanup, -- * Helpers stop, + modifySignal, getBehavior, local, liftSTM, - putLine + putLine, + runGlobalUpdater ) where -import Control.Concurrent.STM +import Control.Concurrent import Control.Applicative -import Updater.Internal hiding (getValue, newSignal) +import Updater.Internal hiding (newSignal, readSignal) import qualified Updater.Internal as Internal - -import Control.Concurrent +import System.IO.Unsafe +-- | +-- Creates a new signal. You can use this signal in any +-- context you want and share it freely between any +-- number of different Updater monads. +newSignal :: a -> Updater (Signal a) +newSignal = liftSTM . Internal.newSignal -- | -- Just a synonym for `empty` from `Alternative`. @@ -56,14 +65,28 @@ -- | -- Gets the current value. --- Return Nothing if the signal is uninitialized. -getValue :: Signal a -> Updater (Maybe a) -getValue = liftSTM . Internal.getValue +readSignal :: Signal a -> Updater a +readSignal = liftSTM . Internal.readSignal -- | --- Creates a new signal and gives you a way to update it. --- It is important to note that because the signal and the --- update function are separate, you can easily have readonly, --- writeonly permissions. -newSignal :: Updater (a -> Updater (), Signal a) -newSignal = liftSTM Internal.newSignal +-- simple combination of readSignal and writeSignal +modifySignal :: Signal a -> (a -> a) -> Updater () +modifySignal s f = readSignal s >>= writeSignal s . f + +-- | +-- this is just a convenience for use in ghci +-- and in the test cases. It will just run +-- the updater it is given in it's own thread. +runGlobalUpdater :: Updater a -> IO () +runGlobalUpdater u = runUpdater $ writeSignal globalUpdater (u >> return ()) + +globalUpdater :: Signal (Updater ()) +{-# NOINLINE globalUpdater #-} +globalUpdater = unsafePerformIO $ do + s <- newSignalIO $ return () + forkIO $ runUpdater $ do + currentUpdater <-getBehavior s + currentUpdater + stop + return s + diff --git a/Updater/Internal.hs b/Updater/Internal.hs new file mode 100644 --- /dev/null +++ b/Updater/Internal.hs @@ -0,0 +1,274 @@ +module Updater.Internal ( + -- Signals + Signal(), + newSignal, + newSignalIO, + writeSignal, + readSignal, + addListener, + -- Updater + Updater(), + onCommit, + getEvent, + getBehavior, + runUpdater, +-- getCleanup, + liftSTM, + onCleanup + ) where + +import Control.Concurrent.STM +import qualified Updater.List as List + +import Control.Applicative +import Control.Exception.Base +import Control.Monad.Fix + +putLine :: String -> Updater () +putLine = onCommit . putStrLn + +--- START: SIGNALS --- + +-- | +-- `Signal` is the portable Signal they can be exchanged between +-- any parts of your program. Internally, they are just a variable and a list of +-- change hooks. +data Signal a = Signal { + signalValue :: TVar a, + signalListeners :: List.LinkedList (a -> Updater ()) + } + +newSignal :: a -> STM (Signal a) +newSignal a = do + value <- newTVar a + listeners <- List.empty + return (Signal value listeners) + +newSignalIO :: a -> IO (Signal a) +newSignalIO a = do + value <- newTVarIO a + listeners <- List.emptyIO + return (Signal value listeners) + + + +readSignal :: Signal a -> STM a +readSignal signal = readTVar $ signalValue signal + +-- | +-- Writes the value to the variable inside the signal +-- and schedules the listeners to run. +-- The listeners will run in the same stm action +-- and with the value you gave. +-- However, they do not run immediately. +-- So you are guaranteed that writeSignal will +-- not have any immediate sideffects other then +-- writing the one single variable. +writeSignal :: Signal a -> a -> Updater () +writeSignal (Signal valueVar listeners) value = do + liftSTM $ writeTVar valueVar value + onCommitUpdater $ liftSTM (List.start listeners) >>= recursion where + recursion Nothing = return () + recursion (Just node) = do + List.value node value :: Updater () + liftSTM (List.next node) >>= recursion + +-- | +-- executes listeners immediately. +-- can lead to breaking of semanitcs if not used carefully +writeSignalNow :: Signal a -> a -> Updater () +writeSignalNow (Signal valueVar listeners) value = do + listeners' <- liftSTM $ List.toList listeners + liftSTM $ writeTVar valueVar value + mapM_ ($ value) listeners' + +-- | +-- the return value will remove the listener +-- use +-- 'fixm \remover -> someListener remover' +-- to add a listener that can remove itself +addListener :: Signal a -> (a -> Updater ()) -> STM (STM ()) +addListener signal listener = do + node <- List.append listener (signalListeners signal) + return (List.delete node) + +addSingletonListener :: Signal a -> (a -> Updater ()) -> STM (STM ()) +addSingletonListener signal listener = mfix add where + add remove = addListener signal (run remove) + run remove value = liftSTM remove >> listener value + +--- END: SIGNALS --- + +data State = State { + stateOnCommitUpdater :: TVar ([Updater ()]), + stateOnCommitIO :: TVar ([IO ()]), + stateCleanup :: Signal () +} + +-- | +-- This monad works very similar to a continuation monad on top of stm. +-- You can do any basic stm computation you want simply using `liftSTM`. +-- However, if you use `getEvent` everything after that call will be executed +-- everytime the `Signal` given to `getEvent` is changed. +-- +-- You can also use the `Alternative` instance to make a union of events. +-- +-- You can also use the `Applicative` instance to run two things \'parallel\'. +-- Parallel meaning that events on one side will not cause the other +-- side to be reevaluated completely. +newtype Updater a = Updater { runUpdater' :: (a -> State -> STM ()) -> State -> STM () } + +getCleanup :: Updater (Signal ()) +getCleanup = fmap stateCleanup getState + +-- | +-- doesn't really work yet +onCleanup :: Updater () -> Updater () +onCleanup cleanup = do + cleanupE <- getCleanup + liftSTM $ addSingletonListener cleanupE (const $ cleanup) + return () + +-- | +-- IO actions given here will be executed once a signal update +-- has been completed. They keep the order in which they are inserted. +onCommit :: IO () -> Updater () +onCommit action = do + state <- getState + liftSTM $ modifyTVar (stateOnCommitIO state) (action:) + +onCommitUpdater :: Updater () -> Updater () +onCommitUpdater action = do + state <- getState + liftSTM $ modifyTVar (stateOnCommitUpdater state) (action:) + +getState :: Updater State +getState = Updater $ \restCalc state -> restCalc state state + +putState :: State -> Updater () +putState state = Updater $ \restCalc _ -> restCalc () state + +-- | +-- Runs everything below it everytime its input signal is updated. +getEvent :: Signal a -> Updater a +getEvent signal = Updater $ \restCalc state-> do + cleanupE <- newSignal () + removeListener <- addListener signal + (\value -> do + writeSignalNow cleanupE () + state' <- getState + liftSTM $ restCalc value (state' { stateCleanup = cleanupE }) + ) + addSingletonListener (stateCleanup state) (const $ do + liftSTM removeListener + writeSignalNow cleanupE () + ) + return () + +-- | +-- Similar to `getEvent` except that it also fires an event immediately, +-- with the value of the current state. +-- +-- >getBehavior signal = liftSTM (readSignal signal) <|> getEvent signal +getBehavior :: Signal a -> Updater a +getBehavior signal = liftSTM (readSignal signal) <|> getEvent signal + + +-- | +-- This will evaluate the `Updater` Monad. +-- It will block until the first run reaches the end. +-- After that, it will return the result and free everything. +-- To prevent signals from reaching the end use `Updater.stop` or `getEvent` with some exit signal. +runUpdater :: Updater a -> IO a +runUpdater updater' = wrapper where + wrapper = do + cleanupSignal <- atomically $ newSignal $ error "should not be accessible" + onException + (run updater' cleanupSignal) + (run (writeSignalNow cleanupSignal ()) cleanupSignal) + + run updater cleanupSignal= do + (resultVar, onCommitAction) <- atomically $ do + onCommitVar <- newTVar [] + onCommitUpdaterVar <- newTVar [] + resultVar <- newEmptyTMVar + runUpdater' + ( do + res <- updater + writeSignalNow cleanupSignal () + onCommit $ atomically $ putTMVar resultVar res) + (const $ const $ return ()) + (State { + stateCleanup = cleanupSignal, + stateOnCommitUpdater = onCommitUpdaterVar, + stateOnCommitIO = onCommitVar }) + let runOnCommitUpdater onCommitUpdaterVal = do + onCommitUs <- newTVar [] + runUpdater' (onCommitUpdaterVal) (const $ const $ return ()) (State + { stateCleanup = error "should not be needed" + , stateOnCommitUpdater = onCommitUs + , stateOnCommitIO = onCommitVar + }) + onCommitUs' <- readTVar onCommitUs + mapM_ runOnCommitUpdater onCommitUs' + readTVar onCommitUpdaterVar >>= mapM_ runOnCommitUpdater + onCommitAction <- readTVar onCommitVar + return (resultVar, onCommitAction) + sequence_ $ reverse onCommitAction + result <- atomically $ takeTMVar resultVar + return result + +liftSTM :: STM a -> Updater a +liftSTM run = Updater (\restCalc state -> run >>= (\x -> restCalc x state)) + +--- START: INSTANCES --- + +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 + signalF <- newSignal Nothing + signalX <- newSignal Nothing + + runUpdater' (updater1 >>= writeSignalNow signalF . Just) (const $ const $ return ()) state + runUpdater' (updater2 >>= writeSignalNow signalX . Just) (const $ const $ return ()) state + + runUpdater' (do + (Just f) <- getBehavior signalF + (Just x) <- getBehavior signalX + state' <- getState + liftSTM $ restCalc (f x) state' + ) (const $ const $ return ()) state + + return () + +instance Alternative Updater where + empty = Updater $ \_ _ -> return () + updater1 <|> updater2 =Updater $ \restCalc state -> do + signal <-newSignal (error "should not be accessed") + cleanupSignal <- newSignal (error "should not be accessed") + + runUpdater' (do + -- we don't want the next line to get cleaned up before + -- both updates have had a chance to fire the initial signal + event <- getEvent signal + state' <- getState + liftSTM $ restCalc event state' + ) (const $ const $ return ()) state + + runUpdater' (updater1 >>= writeSignalNow signal) (const $ const $ return ()) state + runUpdater' (updater2 >>= writeSignalNow signal) (const $ const $ return ()) state + + addSingletonListener (stateCleanup state) (writeSignalNow cleanupSignal) + 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 + fail _ = Updater $ \_ _ -> return () + +--- END: INSTANCES --- diff --git a/Updater/List.hs b/Updater/List.hs new file mode 100644 --- /dev/null +++ b/Updater/List.hs @@ -0,0 +1,194 @@ +-- Taken from the stm-linkedlist package +-- by Joey Adams +{-# LANGUAGE BangPatterns #-} +module Updater.List where + +import Control.Concurrent.STM +import Data.Maybe (isJust, isNothing) +import System.IO (fixIO) + +-- | List handle. Used for insertion and traversal starting at the beginning +-- or end of the list. +newtype LinkedList a = LinkedList (Node a) + +-- | Unwrap the list head, a special 'Node' with the following properties: +-- +-- * @'next' . 'listHead' == 'start'@ +-- +-- * @'prev' . 'listHead' == 'end'@ +-- +-- * @'insertBefore' v . 'listHead' == 'append' v@ +-- +-- * @'insertAfter' v . 'listHead' == 'prepend' v@ +-- +-- * @'value' . 'listHead' ==> /error/@ +-- +-- * @'delete' . 'listHead' ==> /error/@ +listHead :: LinkedList a -> Node a +listHead (LinkedList h) = h + +-- | List node. Used for insertion, traversal, and removal starting at a given +-- item in the list. +-- +-- A Node contains an immutable value of type @a@, and 'TVar's that point to +-- the previous and next nodes. +-- +-- Node equality can be likened to pointer equality in C. Two Node values are +-- considered equal if and only if they were created with the same insertion +-- operation. +data Node a + = Node + { nodePrev :: NodePtr a + , nodeNext :: NodePtr a + , nodeValue :: Maybe a + -- ^ 'Nothing' if this is the list head. + } + +type NodePtr a = TVar (Node a) + +instance Eq (Node a) where + a == b = nodeNext a == nodeNext b + +-- | Extract the value of a node. +value :: Node a -> a +value node = case nodeValue node of + Just v -> v + Nothing -> error "LinkedList.value: list head" + +-- | /O(1)/. Is the list empty? +null :: LinkedList a -> STM Bool +null (LinkedList list_head) = do + first <- readTVar $ nodeNext list_head + return $ isNothing $ nodeValue first + +-- | /O(n)/. Count the number of items in the list. +length :: LinkedList a -> STM Int +length (LinkedList list_head) = foldlHelper (\a _ -> a + 1) 0 nodeNext list_head + +-- | /O(1)/. Create an empty linked list. +empty :: STM (LinkedList a) +empty = do + prev_ptr <- newTVar undefined + next_ptr <- newTVar undefined + let node = Node prev_ptr next_ptr Nothing + writeTVar prev_ptr node + writeTVar next_ptr node + return $ LinkedList node + +-- | /O(1)/. Version of 'empty' that can be used in the 'IO' monad. +emptyIO :: IO (LinkedList a) +emptyIO = do + node <- fixIO $ \node -> do + prev_ptr <- newTVarIO node + next_ptr <- newTVarIO node + return (Node prev_ptr next_ptr Nothing) + return $ LinkedList node + +-- | Insert a node between two adjacent nodes. +insertBetween :: a -> Node a -> Node a -> STM (Node a) +insertBetween v left right = do + prev_ptr <- newTVar left + next_ptr <- newTVar right + let node = Node prev_ptr next_ptr (Just v) + writeTVar (nodeNext left) node + writeTVar (nodePrev right) node + return node + +-- | /O(1)/. Add a node to the beginning of a linked list. +prepend :: a -> LinkedList a -> STM (Node a) +prepend v (LinkedList list_head) = do + right <- readTVar $ nodeNext list_head + insertBetween v list_head right + +-- | /O(1)/. Add a node to the end of a linked list. +append :: a -> LinkedList a -> STM (Node a) +append v (LinkedList list_head) = do + left <- readTVar $ nodePrev list_head + insertBetween v left list_head + +-- | /O(1)/. Insert an item before the given node. +insertBefore :: a -> Node a -> STM (Node a) +insertBefore v node = do + left <- readTVar $ nodePrev node + if left == node && isJust (nodeValue node) + then error "LinkedList.insertBefore: node removed from list" + else insertBetween v left node + +-- | /O(1)/. Insert an item after the given node. +insertAfter :: a -> Node a -> STM (Node a) +insertAfter v node = do + right <- readTVar $ nodeNext node + if right == node && isJust (nodeValue node) + then error "LinkedList.insertAfter: node removed from list" + else insertBetween v node right + +-- | /O(1)/. Remove a node from whatever 'LinkedList' it is in. If the node +-- has already been removed, this is a no-op. +delete :: Node a -> STM () +delete node + | isNothing (nodeValue node) = + error "LinkedList.delete: list head" + | otherwise = do + left <- readTVar $ nodePrev node + right <- readTVar $ nodeNext node + writeTVar (nodeNext left) right + writeTVar (nodePrev right) left + + -- Link list node to itself so subsequent 'delete' calls will be harmless. + writeTVar (nodePrev node) node + writeTVar (nodeNext node) node + +stepHelper :: (Node a -> NodePtr a) -> Node a -> STM (Maybe (Node a)) +stepHelper step node = do + node' <- readTVar $ step node + if node' == node + then return Nothing + else case nodeValue node' of + Just _ -> return $ Just node' + Nothing -> return Nothing + +-- | /O(1)/. Get the previous node. Return 'Nothing' if this is the first item, +-- or if this node has been 'delete'd from its list. +prev :: Node a -> STM (Maybe (Node a)) +prev = stepHelper nodePrev + +-- | /O(1)/. Get the next node. Return 'Nothing' if this is the last item, +-- or if this node has been 'delete'd from its list. +next :: Node a -> STM (Maybe (Node a)) +next = stepHelper nodeNext + +-- | /O(1)/. Get the node corresponding to the first item of the list. Return +-- 'Nothing' if the list is empty. +start :: LinkedList a -> STM (Maybe (Node a)) +start = next . listHead + +-- | /O(1)/. Get the node corresponding to the last item of the list. Return +-- 'Nothing' if the list is empty. +end :: LinkedList a -> STM (Maybe (Node a)) +end = prev . listHead + +-- | Traverse list nodes with a fold function. The traversal terminates when +-- the list head is reached. +-- +-- This is strict in the accumulator. +foldlHelper :: (a -> b -> a) -- ^ Fold function + -> a -- ^ Initial value + -> (Node b -> NodePtr b) -- ^ Step function ('nodePrev' or 'nodeNext') + -> Node b -- ^ Starting node. This node's value is not used! + -> STM a +foldlHelper f z nodeStep start_node = + loop z start_node + where + loop !accum node = do + node' <- readTVar $ nodeStep node + case nodeValue node' of + Nothing -> return accum + Just v -> loop (f accum v) node' + +-- | /O(n)/. Return all of the items in a 'LinkedList'. +toList :: LinkedList a -> STM [a] +toList (LinkedList list_head) = foldlHelper (flip (:)) [] nodePrev list_head + +-- | /O(n)/. Return all of the items in a 'LinkedList', in reverse order. +toListRev :: LinkedList a -> STM [a] +toListRev (LinkedList list_head) = foldlHelper (flip (:)) [] nodeNext list_head