summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authoryokto <>2015-09-17 19:00:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-09-17 19:00:00 (GMT)
commitf743e29ff75e5778787e3c6408debc12a4a434c5 (patch)
treeb57dfb6beb03f0dc1fad4e623242e05f4275f66c
parentdbe624c1af3d75abfb6222214e9ae7595735c775 (diff)
version 0.3HEAD0.3master
-rw-r--r--Updater.cabal10
-rw-r--r--Updater.hs156
-rw-r--r--Updater/Internal.hs519
-rw-r--r--Updater/List.hs90
4 files changed, 427 insertions, 348 deletions
diff --git a/Updater.cabal b/Updater.cabal
index d652e07..d3d27bf 100644
--- a/Updater.cabal
+++ b/Updater.cabal
@@ -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 @@ Description: Read the homepage for more information.
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
diff --git a/Updater.hs b/Updater.hs
index 94b58a3..5ebab2a 100644
--- a/Updater.hs
+++ b/Updater.hs
@@ -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
- \ No newline at end of file
+-- 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 \ No newline at end of file
diff --git a/Updater/Internal.hs b/Updater/Internal.hs
index 090ec9a..f712886 100644
--- a/Updater/Internal.hs
+++ b/Updater/Internal.hs
@@ -1,31 +1,86 @@
+{-# 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,76 +89,70 @@ putLine = onCommit . putStrLn
-- 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)
-
-
+ num <- modifyMVar signalNumVar $ \n -> return (n+1,n)
+ -- putStrLn (show num ++ ": new signal")
+ return (Signal value listeners num)
-readSignal :: Signal a -> STM a
-readSignal signal = readTVar $ signalValue signal
+readSignal :: Signal a -> IO a
+readSignal signal = readIORef $ 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
+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)
-- |
--- 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 ())
+-- 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.
@@ -116,159 +165,195 @@ data State = State {
-- 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
-
+newtype Updater a = Updater {
+ runUpdater' :: (a -> DownState -> IO UpState) -> DownState -> IO UpState
+ }
--- |
--- 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))
+-- 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
+
+-- 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
+
+cacheStateful' :: Updater a -> Updater (Updater a)
+cacheStateful' updater = Updater $ \restCalc downState-> do
+ signal <- newSignal Nothing
+ cleanup <- newIORef (return ())
+
+
+ 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
+
+ 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
+
+ return (upstate1 <> upstate2)
+
+cacheStateless' :: Updater a -> Updater (Updater a)
+cacheStateless' updater = Updater $ \restCalc downState-> do
+ signal <- newSignal (error "unreadable event")
+ cleanup <- newIORef (return ())
+
+ upstate1 <- restCalc (Updater $ \restCalc2 _ -> do
+ removeListener <- addListener signal restCalc2
+ return $ mempty { stateOnCleanup = removeListener }
+ ) downState
+
+ 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
+
+
+ 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 ---
-instance Functor Updater where
- fmap f (Updater giveMeNext) = Updater (\next -> giveMeNext (next . f))
-
+-- 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
-
- 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 ()
+ (Updater giveMeNext1) <*> (Updater giveMeNext2) = Updater $ \restCalc state -> do
+ varF <- newIORef Nothing
+ varX <- newIORef Nothing
+ varCleanup <- newIORef $ return ()
+
+ 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
+
+ upState1 <- giveMeNext1 (\x state' -> writeIORef varF (Just x) >> update state') state
+ upState2 <- giveMeNext2 (\x state' -> writeIORef varX (Just x) >> update state') state
+
+ 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")
-
- 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 ()
+ empty = Updater $ \_ _ -> return mempty
+ (Updater giveMeNext1) <|> (Updater giveMeNext2) = Updater $ \restCalc state -> do
+ var <-newIORef (error "should not be accessed")
+ varCleanup <- newIORef $ return ()
+
+ let update state' = do
+ val <- readIORef var
+ join (readIORef varCleanup)
+ upstate <- restCalc val state'
+ writeIORef varCleanup $ stateOnCleanup upstate
+ return $ upstate {
+ stateOnCleanup = 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 --- \ No newline at end of file
diff --git a/Updater/List.hs b/Updater/List.hs
index 0412a60..fdb0883 100644
--- a/Updater/List.hs
+++ b/Updater/List.hs
@@ -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 @@ data Node a
-- ^ '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 @@ value node = case nodeValue node of
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 @@ stepHelper step node = do
-- | /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 @@ 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
+ -> 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