Updater 0.2 → 0.3

raw patch · 4 files changed

+413/−334 lines, 4 filesdep −stmPVP ok

version bump matches the API change (PVP)

Dependencies removed: stm

API changes (from Hackage documentation)

Files

• Updater.cabal +5/−5
• Updater.hs +80/−76
• Updater/Internal.hs +288/−203
• Updater/List.hs +40/−50

@@ -1,5 +1,5 @@ Name:	Updater-Version:	0.2+Version:	0.3 Cabal-Version:	>= 1.6 License:	Apache-2.0 License-File:	LICENSE@@ -12,14 +12,14 @@ Build-Type:	Simple  Library-  Build-Depends:	base >= 3 && < 5, stm+  Build-Depends:	base >= 3 && < 5   ghc-options:     -Wall -fno-warn-tabs   Exposed-Modules:     Updater+    Updater.Internal   Other-Modules:-    Updater.List, Updater.Internal+    Updater.List -source-repository this+source-repository head   type:        git   location:    https://github.com/yokto/Updater.git-  tag: 0.2

@@ -1,92 +1,96 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Updater (-	-- * Signals- 	Signal(),- 	newSignal,-	newSignalIO,- 	writeSignal,-	readSignal,--- 	addListener,-	-- * Updater Monad-	Updater(),-	runUpdater,-	getEvent,-	onCommit,-	onCleanup,-	-- * Helpers-	stop,-	modifySignal,-	getBehavior,-	local,-	liftSTM,-	putLine,-	runGlobalUpdater+	Event (),+	Behavior (),+	newEvent,+	cacheStateful,+	cacheStateless,+	sample,+	foldEvent,+		runEvent,+	runGlobalEvent,+	debug,+	debugCleanup,+	hold,+	unsafeLiftIO 	) where  import Control.Concurrent import Control.Applicative-import Updater.Internal hiding (newSignal, readSignal)-import qualified Updater.Internal as Internal+--import Control.Concurrent.MVar+--import Data.Monoid+import Control.Monad+import Data.Monoid+import Control.Monad.Fix+import Updater.Internal import System.IO.Unsafe+-- import Debug.Trace+import Foreign.StablePtr --- |--- 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+instance Monoid (Event a) where+	mempty = empty+	mappend = (<|>) --- |--- Just a synonym for `empty` from `Alternative`.--- It basically prevents signals from ever progressing beyond this point.--- You can use this to make a filter for instance------ >when (condition) stop-stop :: Updater a-stop = empty+newEvent :: IO (Event a, a -> IO ())+newEvent = do+	(ev,button) <- newEvent'+	return (Event ev, button) --- |--- Just for some quick debugging------ >putLine = onCommit . putStrLn-putLine :: String -> Updater ()-putLine = onCommit . putStrLn+-- | The input will only be evaluated once,+-- no matter how often the output 'Event' is used.+-- Since it is stateless, when the output 'Event' is used, it will first+-- have to wait for events.+cacheStateless :: Event a -> Behavior (Event a)+cacheStateless (Event u) = Behavior (Event `fmap` cacheStateless' u) --- |--- Returns immediately after registering the given computation.--- However, events from inside will not spread outside, except for--- the initial one.------ It is implemented like this------ >local computation = return () <|> (computation >> stop)-local :: Updater a -> Updater ()-local computation = return () <|> (computation >> stop)+-- | The input will only be evaluated once,+-- no matter how often the ouput 'Event' is used.+-- Since it is stateful, when the output 'Event' is used, it will+-- immediately continue with the last Event it received if+-- such an event exists.+cacheStateful :: Event a -> Behavior (Event a)+cacheStateful (Event d) = Behavior (Event `fmap` cacheStateful' d) --- |--- Gets the current value.-readSignal :: Signal a -> Updater a-readSignal = liftSTM . Internal.readSignal+-- | This can be thought of as polling a behavior. It will only fire once.+sample :: Behavior a -> Event a+sample (Behavior c) = Event c --- |--- simple combination of readSignal and writeSignal-modifySignal :: Signal a -> (a -> a) -> Updater ()-modifySignal s f = readSignal s >>= writeSignal s . f+-- | This just only forwards the first event+-- It is probably most useful for Events crated using+-- 'cacheStateful'+hold :: Event a -> Behavior a+hold (Event e) = Behavior (justOne e) +-- | 'Left io' events will be executed.+-- The first 'Right res' event will end the function and return res.+runEvent :: Event (Either (IO ()) res) -> IO res+runEvent (Event u) = runUpdater u++-- | +-- This can be implemented using mfix, cacheStateful, ...+-- +-- If you get into trouble and really need multiple recursively defined+-- Events you can use mfix to do that.+-- You should however look at the implementation of 'foldEvent' and+-- the SlotMachine example first.+-- In particular, make sure you understande that you need to use+-- 'sample . hold' on the recursive signal in order to avoid infinite recursion.+foldEvent :: (b -> a -> b) -> b -> Event a -> Event b+foldEvent f b updater = join $ sample $ mfix $ \discrete -> cacheStateful $ return b <|> (do+	a' <- updater+	b' <- sample $ hold discrete+	return (f b' a'))+ -- |--- this is just a convenience for use in ghci+-- 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-	+-- the Event it is given in it's own thread.+runGlobalEvent :: Event (IO ()) -> IO ()+{-# NOINLINE runGlobalEvent #-}+runGlobalEvent = unsafePerformIO $ do+	_ <- newStablePtr runGlobalEvent+	(ev, button) <- newEvent :: IO (Event (Event (IO ())), Event (IO ()) -> IO ())+	var <- newEmptyMVar+	_ <- forkIO $ (runEvent $ sample (onCommit (putMVar var ())) >> Left `fmap` join ev)+	takeMVar var+	return button

@@ -1,32 +1,87 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} module Updater.Internal (- 	-- Signals- 	Signal(),- 	newSignal,-	newSignalIO,- 	writeSignal,-	readSignal,- 	addListener,-	-- Updater-	Updater(),+	Event (..),+	Behavior (..),+ 	Updater (..),+--  	getEvent',+--  	getBehavior',+	newEvent',+	cacheStateless',+	cacheStateful',+ 	runUpdater,+ 	unsafeLiftIO,+	debug,+	debugCleanup, 	onCommit,-	getEvent,-	getBehavior,-	runUpdater,---	getCleanup,-	liftSTM,-	onCleanup+	justOne,+	UpState (..),+	DownState (..) 	) where -import Control.Concurrent.STM+import Control.Concurrent.MVar+--import GHC.Conc.Sync hiding (modifyMVar_) import qualified Updater.List as List  import Control.Applicative-import Control.Exception.Base+import Control.Monad+import Data.Monoid+-- import Control.Exception.Base import Control.Monad.Fix+import System.Mem.Weak+-- import Debug.Trace+import Data.IORef+import System.IO.Unsafe -putLine :: String -> Updater ()-putLine = onCommit . putStrLn+-- | Push based Updater. +newtype Event a = Event { getEvent' :: Updater a }+  deriving (Functor, Applicative, Alternative, Monad) +-- | Pull based Updater+newtype Behavior a = Behavior { getBehavior' :: Updater a }+  deriving (Functor, Applicative, Monad, MonadFix)++-- | Don't execute the io-action returned by 'newEvent'.+-- Also, fork; don't block.+-- +unsafeLiftIO :: IO a -> Behavior a+unsafeLiftIO = Behavior . liftIO++globalLock :: MVar ()+{-# NOINLINE globalLock #-}+globalLock = unsafePerformIO $ newMVar ()++signalNumVar :: MVar Int+{-# NOINLINE signalNumVar #-}+signalNumVar = unsafePerformIO $ newMVar 1++withGlobalLock :: IO a -> IO a+withGlobalLock io = do+	takeMVar globalLock+	res <- io+	putMVar globalLock ()+	return res++++-- |+-- Just for some quick debugging+--+-- >putLine = unsafeLiftIO . putStrLn+debug :: String -> Behavior ()+debug = unsafeLiftIO . putStrLn++-- |+-- This can be useful to spot when listeners are removed.+debugCleanup :: String -> Behavior ()+debugCleanup string = Behavior $ Updater $ \restCalc downState -> do+	upState <- restCalc () downState+	return $ mempty { stateOnCleanup = putStrLn string } <> upState++onCommit :: IO () -> Behavior ()+onCommit io = Behavior $ Updater $ \restCalc downState -> do+	upState <- restCalc () downState+	return $ mempty { stateOnCommit = io } <> upState+ --- START: SIGNALS ---  -- |@@ -34,77 +89,71 @@ -- 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 ())+	signalValue :: IORef a,+	signalListeners :: List.LinkedList (Weak (Signal a, a -> DownState -> IO UpState)),+	signalNum :: Int 	} -newSignal :: a -> STM (Signal a)+newSignal :: a -> IO (Signal a) newSignal a = do-	value <- newTVar a+	value <- newIORef 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+	num <- modifyMVar signalNumVar $ \n -> return (n+1,n)+	-- putStrLn (show num ++ ": new signal")+	return (Signal value listeners num) --- |--- 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+readSignal :: Signal a -> IO a+readSignal signal = readIORef $ signalValue signal  -- |--- 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'+writeSignal :: Signal a -> a -> DownState -> IO UpState+writeSignal (Signal valueVar listeners num) value downState = do+	writeIORef valueVar value+	list <- List.toList listeners+	-- putStrLn (show num ++ ": length: " ++ show (length list))+	let f weakRef = do+			res <- deRefWeak weakRef+			case res of+				 (Just (_,listener)) -> listener value downState+				 _ -> return mempty+	upStates <- mapM f list+	return (foldl (<>) mempty upStates)  -- |--- 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 ())+-- The return value will remove the listener.+-- IMPORTANT: If the remover gets garbage+-- collected the listener will be removed.+-- any references from the listener to the+-- remover don't count.+addListener :: Signal a -> (a -> DownState -> IO UpState) -> IO (IO ()) 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+	let listener' a downState = {- putStrLn (show (signalNum signal) ++ ": runListener") >> -} listener a downState+	-- putStrLn $ (show $ signalNum signal) ++ ": add listener"+	weakRef <- newIORef (error "should not be readable")+	node <- List.append (unsafePerformIO $ readIORef weakRef) (signalListeners signal)+	-- next who lines are just so (signal, listeners) won't be collected+	key <- newIORef undefined+	let remove = (List.delete node) >> newIORef key >> return ()+	weak <- mkWeak key (signal, listener') $ Just $ do+		-- putStrLn $ show (signalNum signal) ++ ": cleaning up signal"+		remove+	writeIORef weakRef weak+	return (remove {- >> putStrLn ((show $ signalNum signal) ++": remove listener") -})  --- END: SIGNALS --- -data State = State {-	stateOnCommitUpdater :: TVar ([Updater ()]),-	stateOnCommitIO :: TVar ([IO ()]),-	stateCleanup :: Signal ()-}+data DownState = DownState {+	} +data UpState = UpState {+	stateOnCleanup :: IO (),+	stateOnCommit :: IO ()+	}++instance Monoid UpState where+	mempty = UpState (return ()) (return ())+	(UpState c1 d1) `mappend` (UpState c2 d2) = UpState (c1 >> c2) (d1 >> d2)+ -- | -- 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`.@@ -116,159 +165,195 @@ -- 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 () }+newtype Updater a = Updater { +	runUpdater' :: (a -> DownState -> IO UpState) -> DownState -> IO UpState+	} -getCleanup :: Updater (Signal ())-getCleanup = fmap stateCleanup getState+-- it is important this not be used for Updaters that can fire multiple times+-- it can only be used for Continuous+instance MonadFix Updater where+	mfix = fixUpdater --- |--- doesn't really work yet-onCleanup :: Updater () -> Updater ()-onCleanup cleanup = do-	cleanupE <- getCleanup-	liftSTM $ addSingletonListener cleanupE (const $ cleanup)-	return ()+-- it is important this not be used for Updaters that can fire multiple times+-- it can only be used for Continuous+fixUpdater :: (a -> Updater a) -> Updater a+fixUpdater toUpdater = Updater $ \restCalc downState -> do+	inputVar <- newEmptyMVar+	runUpdater' (toUpdater $ unsafePerformIO $ takeMVar inputVar)+		(\x downState2 -> do+			isEmpty <- isEmptyMVar inputVar+			when (not isEmpty) (error "continuous run twice")+			putMVar inputVar x+			restCalc x downState2+			)+		downState --- |--- 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:)+cacheStateful' :: Updater a -> Updater (Updater a)+cacheStateful' updater = Updater $ \restCalc downState->  do+	signal <- newSignal Nothing+	cleanup <- newIORef (return ()) -onCommitUpdater :: Updater () -> Updater ()-onCommitUpdater action = do-	state <- getState-	liftSTM $ modifyTVar (stateOnCommitUpdater state) (action:) -getState :: Updater State-getState = Updater $ \restCalc state -> restCalc state state+	upstate1 <- restCalc (Updater $ \restCalc2 downState2 -> do+		res <- readSignal signal+		upState <- case res of+			 (Just res') -> do+				upState' <- restCalc2 res' downState2+				oldCleanup <- readIORef cleanup+				writeIORef cleanup (oldCleanup >> stateOnCleanup upState')+				return upState' { stateOnCleanup = join $ readIORef cleanup } +			 Nothing -> return mempty+		removeListener <- addListener signal (\x downState3 -> case x of+			(Just x') -> restCalc2 x' downState3+			Nothing -> return mempty)+		return $ upState <> mempty { stateOnCleanup = removeListener }+		) downState -putState :: State -> Updater ()-putState state = Updater $ \restCalc _ -> restCalc () state+	upstate2 <- runUpdater' updater+		(\x downState' -> do+			join $ readIORef cleanup+			upState <- writeSignal signal (Just x) downState'+			writeIORef cleanup (stateOnCleanup upState)+			return upState { stateOnCleanup = join $ readIORef cleanup }+			)+		downState --- |--- 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 ()+	return (upstate1 <> upstate2) --- |--- 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-	+cacheStateless' :: Updater a -> Updater (Updater a)+cacheStateless' updater = Updater $ \restCalc downState->  do+	signal <- newSignal (error "unreadable event")+	cleanup <- newIORef (return ()) --- |--- 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+	upstate1 <- restCalc (Updater $ \restCalc2 _ -> do+		removeListener <- addListener signal restCalc2+		return $ mempty { stateOnCleanup = removeListener }+		) downState -liftSTM :: STM a -> Updater a-liftSTM run = Updater (\restCalc state -> run >>= (\x -> restCalc x state))+	upstate2 <- runUpdater' updater+		(\x downState' -> do+			join $ readIORef cleanup+			upState <- writeSignal signal x downState'+			writeIORef cleanup (stateOnCleanup upState)+			return upState { stateOnCleanup = join $ readIORef cleanup }+			)+		downState ---- START: INSTANCES --- -instance Functor Updater where-	fmap f (Updater giveMeNext) = Updater (\next -> giveMeNext (next . f))+	return (upstate1 <> upstate2) +newEvent' :: IO (Updater a, a -> IO ())+newEvent' = do+	signal <- newSignal (error "unreadable")+	cleanupVar <- newIORef (return () :: IO ())+	let+		updater = Updater $ \restCalc _ -> do+			removeListener <- addListener signal (\a downState2 -> restCalc a downState2)+			return mempty { stateOnCleanup = removeListener }+		button a = do+			takeMVar globalLock+			join $ readIORef cleanupVar+			upState <- writeSignal signal a (error "no down state yet")+			writeIORef cleanupVar (stateOnCleanup upState)+			putMVar globalLock ()+			stateOnCommit upState+	return (updater, button)++runUpdater :: Updater (Either (IO ()) res) -> IO res+runUpdater (Updater giveMeNext) = do+	resVar <- newEmptyMVar++	upState <- withGlobalLock $ do+		giveMeNext (\val _ -> do+			resMay <-isEmptyMVar resVar+			if resMay+				then case val of+					(Left io) -> return mempty { stateOnCommit = io }+					(Right res) -> putMVar resVar res >> return mempty+				else return mempty+			) DownState {}++	stateOnCommit upState++	res <- takeMVar resVar+	withGlobalLock $ stateOnCleanup upState+	return res++justOne :: Updater a -> Updater a+justOne (Updater giveMeNext) = Updater $ \restCalc downState -> do+	restVar <- newIORef restCalc+	cleanupVar <- newIORef (return ())+	upState' <- giveMeNext (\x downState2 -> do+		rest <- readIORef restVar+		writeIORef restVar (\_ _ -> return mempty)+		upState <- rest x downState2+		writeIORef cleanupVar $ stateOnCleanup upState+		return upState { stateOnCleanup = return () }+		) downState+	return $ upState' <> mempty { stateOnCleanup = join $ readIORef cleanupVar }++liftIO :: IO a -> Updater a+liftIO run = Updater (\restCalc state -> run >>= (\x -> restCalc x state))++--- START: INSTANCES ---++-- TODO: cleanup  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+ 	(Updater giveMeNext1) <*> (Updater giveMeNext2) = Updater $ \restCalc state -> do+		varF <- newIORef Nothing+		varX <- newIORef Nothing+		varCleanup <- newIORef $ return () - 			runUpdater' (updater1 >>= writeSignalNow signalF . Just) (const $ const $ return ()) state- 			runUpdater' (updater2 >>= writeSignalNow signalX . Just) (const $ const $ return ()) state+		let update state' = do+				f' <- readIORef varF+				x' <- readIORef varX+				case (f', x') of+					(Just f, Just x) -> do+						join $ readIORef varCleanup+						upstateC <- restCalc (f x) state'+						writeIORef varCleanup $ stateOnCleanup upstateC+						return $ upstateC {+							stateOnCleanup = return ()+							}+					_ -> return mempty -			runUpdater' (do-				(Just f) <- getBehavior signalF-				(Just x) <- getBehavior signalX-				state' <- getState-				liftSTM $ restCalc (f x) state'-				) (const $ const $ return ()) state+		upState1 <- giveMeNext1 (\x state' -> writeIORef varF (Just x) >> update state') state+		upState2 <- giveMeNext2 (\x state' -> writeIORef varX (Just x) >> update state') state - 			return ()+		return $ upState1 `mappend` upState2 `mappend` mempty { +			stateOnCleanup = join $ readIORef varCleanup+			}  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")+	empty = Updater $ \_ _ -> return mempty+	(Updater giveMeNext1) <|> (Updater giveMeNext2) = Updater $ \restCalc state -> do+		var <-newIORef (error "should not be accessed")+		varCleanup <- newIORef $ return () -		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+		let update state' = do+			val <- readIORef var+			join (readIORef varCleanup)+			upstate <- restCalc val state' +			writeIORef varCleanup $ stateOnCleanup upstate+			return $ upstate {+				stateOnCleanup = return ()+				} -		runUpdater' (updater1 >>= writeSignalNow signal) (const $ const $ return ()) state-		runUpdater' (updater2 >>= writeSignalNow signal) (const $ const $ return ()) state-			-		addSingletonListener (stateCleanup state) (writeSignalNow cleanupSignal)-		return ()+		cleanup1 <- giveMeNext1 (\x state' -> writeIORef var x >> update state') state+		cleanup2 <-giveMeNext2 (\x state' -> writeIORef var x >> update state') state +		return $ cleanup1 `mappend` cleanup2 `mappend` mempty {+			stateOnCleanup = join $ readIORef varCleanup+			}+ 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 ()+	fail _ = Updater $ \_ _ -> return mempty++instance Functor Updater where+	fmap f (Updater giveMeNext) = Updater (\next -> giveMeNext (next . f))  --- END: INSTANCES ---

@@ -3,9 +3,8 @@ {-# LANGUAGE BangPatterns #-} module Updater.List where -import Control.Concurrent.STM+import Data.IORef 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.@@ -44,7 +43,7 @@             -- ^ 'Nothing' if this is the list head.         } -type NodePtr a = TVar (Node a)+type NodePtr a = IORef (Node a)  instance Eq (Node a) where     a == b = nodeNext a == nodeNext b@@ -56,91 +55,82 @@                  Nothing -> error "LinkedList.value: list head"  -- | /O(1)/. Is the list empty?-null :: LinkedList a -> STM Bool+null :: LinkedList a -> IO Bool null (LinkedList list_head) = do-    first <- readTVar $ nodeNext list_head+    first <- readIORef $ nodeNext list_head     return $ isNothing $ nodeValue first  -- | /O(n)/. Count the number of items in the list.-length :: LinkedList a -> STM Int+length :: LinkedList a -> IO 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 :: IO (LinkedList a) empty = do-    prev_ptr <- newTVar undefined-    next_ptr <- newTVar undefined+    prev_ptr <- newIORef undefined+    next_ptr <- newIORef 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)+    writeIORef prev_ptr node+    writeIORef next_ptr node     return $ LinkedList node  -- | Insert a node between two adjacent nodes.-insertBetween :: a -> Node a -> Node a -> STM (Node a)+insertBetween :: a -> Node a -> Node a -> IO (Node a) insertBetween v left right = do-    prev_ptr <- newTVar left-    next_ptr <- newTVar right+    prev_ptr <- newIORef left+    next_ptr <- newIORef right     let node = Node prev_ptr next_ptr (Just v)-    writeTVar (nodeNext left) node-    writeTVar (nodePrev right) node+    writeIORef (nodeNext left) node+    writeIORef (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 :: a -> LinkedList a -> IO (Node a) prepend v (LinkedList list_head) = do-    right <- readTVar $ nodeNext list_head+    right <- readIORef $ 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 :: a -> LinkedList a -> IO (Node a) append v (LinkedList list_head) = do-    left <- readTVar $ nodePrev list_head+    left <- readIORef $ 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 :: a -> Node a -> IO (Node a) insertBefore v node = do-    left <- readTVar $ nodePrev node+    left <- readIORef $ 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 :: a -> Node a -> IO (Node a) insertAfter v node = do-    right <- readTVar $ nodeNext node+    right <- readIORef $ 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 a -> IO () 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+        left <- readIORef $ nodePrev node+        right <- readIORef $ nodeNext node+        writeIORef (nodeNext left) right+        writeIORef (nodePrev right) left          -- Link list node to itself so subsequent 'delete' calls will be harmless.-        writeTVar (nodePrev node) node-        writeTVar (nodeNext node) node+        writeIORef (nodePrev node) node+        writeIORef (nodeNext node) node -stepHelper :: (Node a -> NodePtr a) -> Node a -> STM (Maybe (Node a))+stepHelper :: (Node a -> NodePtr a) -> Node a -> IO (Maybe (Node a)) stepHelper step node = do-    node' <- readTVar $ step node+    node' <- readIORef $ step node     if node' == node         then return Nothing         else case nodeValue node' of@@ -149,22 +139,22 @@  -- | /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 :: Node a -> IO (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 :: Node a -> IO (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 :: LinkedList a -> IO (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 :: LinkedList a -> IO (Maybe (Node a)) end = prev . listHead  -- | Traverse list nodes with a fold function.  The traversal terminates when@@ -175,20 +165,20 @@             -> 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+            -> IO a foldlHelper f z nodeStep start_node =         loop z start_node     where         loop !accum node = do-            node' <- readTVar $ nodeStep node+            node' <- readIORef $ 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 a -> IO [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 a -> IO [a] toListRev (LinkedList list_head) = foldlHelper (flip (:)) [] nodeNext list_head