summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authoryokto <>2015-08-03 17:32:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-08-03 17:32:00 (GMT)
commitdbe624c1af3d75abfb6222214e9ae7595735c775 (patch)
tree16377d057a598824853fc01890a4c471381b7595
parentc0fb9754403ba77dca24868b356f962353b67f3a (diff)
version 0.20.2
-rw-r--r--Updater.cabal7
-rw-r--r--Updater.hs53
-rw-r--r--Updater/Internal.hs274
-rw-r--r--Updater/List.hs194
4 files changed, 511 insertions, 17 deletions
diff --git a/Updater.cabal b/Updater.cabal
index efa7771..d652e07 100644
--- 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 @@ Build-Type: Simple
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
index 88a3917..94b58a3 100644
--- a/Updater.hs
+++ b/Updater.hs
@@ -3,7 +3,9 @@ module Updater (
-- * Signals
Signal(),
newSignal,
- getValue,
+ newSignalIO,
+ writeSignal,
+ readSignal,
-- addListener,
-- * Updater Monad
Updater(),
@@ -13,19 +15,26 @@ module Updater (
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 System.IO.Unsafe
-import Control.Concurrent
-
+-- |
+-- 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 @@ local computation = return () <|> (computation >> stop)
-- |
-- 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 \ No newline at end of file
+-- 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
+ \ No newline at end of file
diff --git a/Updater/Internal.hs b/Updater/Internal.hs
new file mode 100644
index 0000000..090ec9a
--- /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 --- \ No newline at end of file
diff --git a/Updater/List.hs b/Updater/List.hs
new file mode 100644
index 0000000..0412a60
--- /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