Updater 0.1 → 0.2

raw patch · 4 files changed

+511/−17 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Updater.cabal +5/−2
• Updater.hs +38/−15
• Updater/Internal.hs +274/−0
• Updater/List.hs +194/−0

@@ -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

@@ -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+	

@@ -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 ---

@@ -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