diff --git a/example/Example.hs b/example/Example.hs --- a/example/Example.hs +++ b/example/Example.hs @@ -2,12 +2,13 @@ import System.Posix.IO -import qualified System.Posix.IO.Select as S import System.Posix.IO.Select.STM +import Control.Concurrent.STM.RunOrElse import qualified System.Posix.IO.Select.MVar as M import Control.Concurrent import Control.Concurrent.STM.TMVar import Control.Concurrent.STM +import Control.Concurrent.STM.TChan flags :: OpenFileFlags @@ -18,11 +19,15 @@ newEmptyTMVarIO >>= \t -> forkIO (interruptor t) >> putStrLn "The interruptor has been launched." >> + newTChanIO >>= \c -> + forkIO (interruptor2 c) >> + putStrLn "The TChan interruptor has been launched." >> openFd "fifo" ReadOnly Nothing flags >>= \fd -> openFd "fifo2" ReadOnly Nothing flags >>= \fd2 -> openFd "fifo3" ReadOnly Nothing flags >>= \fd3 -> openFd "fifo4" ReadOnly Nothing flags >>= \fd4 -> putStrLn "The file was opened, so let the waiting game begin!" >> + --selectOrReadTChan [fd,fd2,fd3,fd4] [] [] (Time 15 0) c >>= \ret -> selectOrTakeTMVar [fd,fd2,fd3,fd4] [] [] (Time 15 0) t >>= \ret -> case ret of Left 0 -> putStrLn "select() timed out on the files." @@ -32,3 +37,7 @@ interruptor :: TMVar String -> IO () interruptor t = threadDelay (10 * 1000000) >> atomically (putTMVar t "Bwahahaha, the interruptor was first!") + +interruptor2 :: TChan String -> IO () +interruptor2 c = threadDelay (10 * 1000000) >> + atomically (writeTChan c "Bwhaha, TChan interruptor was first!") diff --git a/select.cabal b/select.cabal --- a/select.cabal +++ b/select.cabal @@ -1,5 +1,5 @@ Name: select -Version: 0.1 +Version: 0.2 Synopsis: Give the select(2) POSIX function a simple STM interface Homepage: http://nonempty.org/software/haskell-select License: BSD3 @@ -23,21 +23,30 @@ ["Control.Concurrent.STM.TMVarIO"] and "Control.Concurrent.MVarIO" put the return value of IO actions into a 'TMVar' or an 'MVar', respectively. . - ["System.Posix.IO.Select.STM"] and "System.Posix.IO.Select.MVar" do the above for - @select@. + ["Control.Concurrent.STM.RunOrElse"] defines functions that give you + the return value of whatever finishes first of an IO action and an STM + operation. . + ["System.Posix.IO.Select.STM"] and "System.Posix.IO.Select.MVar" do the above + for the special case @select@. + . /NOTE/: I feel I'm occupying prime namespace realestate with a package name like select. I'll happily let myself be chased away if anybody else wants to use this package name. Let me know. . - /CAVEAT/: I'm not an experienced Haskeller, and this is my first foray into - FFI in general. + /NOTE 2/: The vector dependency comes from me not spending time figuring out + how to pass lists of data to C without first turning them into vectors. It'll + probably disappear soon. + . + /CAVEAT/: I'm not an experienced Haskeller (as you can tell from note 2), and + this is my first foray into FFI in general. Use with caution. Library Exposed-modules: Control.Concurrent.MVarIO, Control.Concurrent.STM.TMVarIO, + Control.Concurrent.STM.RunOrElse, System.Posix.IO.Select, System.Posix.IO.Select.STM, System.Posix.IO.Select.Types, diff --git a/src/Control/Concurrent/STM/RunOrElse.hs b/src/Control/Concurrent/STM/RunOrElse.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/RunOrElse.hs @@ -0,0 +1,32 @@ +module Control.Concurrent.STM.RunOrElse(runOrElse, runOrTakeTMVar) where + +import Control.Applicative +import Control.Concurrent.STM +import Control.Concurrent.STM.TMVarIO + +-- | @'runOrElse' action stm@ runs the IO action @action@ and attempts +-- the STM operation @stm@, returning the return value which is +-- available first. If @action@ returns first, then @stm@ is not +-- run. If @stm@ returns first, @action@ may or may not complete, but +-- its return value is discarded. +-- +-- 'runOrTakeTMVar' is a special case +-- of this function, where @stm@ is simply 'takeTMVar' applied to the +-- given 'TMVar'. +runOrElse :: IO a -> STM b -> IO (Either a b) +runOrElse action stm = run action >>= \tm -> + atomically ((Left <$> takeTMVar tm) `orElse` (Right <$> stm)) + +-- | This version of 'Control.Concurrent.STM.TMVarIO.run' takes an +-- additional 'TMVar', and returns its content /or/ the result of the +-- IO action, depending on which is available first. Note that the +-- action is /not/ interrupted if the 'TMVar' is the winner, so you +-- may want to make sure it doesn't stick around forever. +-- +-- @'runOrTakeTMVar' action tm = 'runOrElse' action ('takeTMVar' tm)@. +-- +-- The function was originally made to support +-- 'System.Posix.IO.Select.STM.selectOrTakeTMVar', the reason this +-- library exists. +runOrTakeTMVar :: IO a -> TMVar b -> IO (Either a b) +runOrTakeTMVar action tm = runOrElse action (takeTMVar tm) diff --git a/src/Control/Concurrent/STM/TMVarIO.hs b/src/Control/Concurrent/STM/TMVarIO.hs --- a/src/Control/Concurrent/STM/TMVarIO.hs +++ b/src/Control/Concurrent/STM/TMVarIO.hs @@ -1,6 +1,6 @@ -- | Perform an IO action, and place its result in a 'TMVar'. See -- also "Control.Concurrent.MVarIO" for an 'MVar' version. -module Control.Concurrent.STM.TMVarIO (run, runOrTakeTMVar) where +module Control.Concurrent.STM.TMVarIO (run) where import Data.Functor import Control.Concurrent @@ -14,19 +14,6 @@ run action = newEmptyTMVarIO >>= \tm -> forkIO (run' action tm) >> return tm - --- | This version of 'run' takes an additional 'TMVar', and returns --- its content /or/ the result of the IO action, depending on which is --- available first. Note that the action is /not/ interrupted if the --- 'TMVar' is the winner, so you may want to make sure it doesn't --- stick around forever. --- --- The function was made to support --- 'System.Posix.IO.Select.STM.selectOrTakeTMVar', the reason this --- library exists, and may not be useful outside of that context. -runOrTakeTMVar :: IO a -> TMVar b -> IO (Either a b) -runOrTakeTMVar action tm1 = run action >>= \tm2 -> - atomically ((Left <$> takeTMVar tm2) `orElse` (Right <$> takeTMVar tm1)) run' :: IO a -> TMVar a -> IO () run' action tm = action >>= \ret -> diff --git a/src/System/Posix/IO/Select/STM.hs b/src/System/Posix/IO/Select/STM.hs --- a/src/System/Posix/IO/Select/STM.hs +++ b/src/System/Posix/IO/Select/STM.hs @@ -1,11 +1,12 @@ -- | Treat the POSIX @select(2)@ function as a 'TMVar' 'CInt'. -module System.Posix.IO.Select.STM (select, selectOrTakeTMVar, Timeout(Never, Time)) where +module System.Posix.IO.Select.STM (select, selectOrTakeTMVar, selectOrElse, selectOrReadTChan, Timeout(Never, Time)) where import System.Posix.IO.Select.Types import qualified System.Posix.IO.Select as S import Foreign.C.Types import Control.Concurrent.STM +import qualified Control.Concurrent.STM.RunOrElse as ROE import qualified Control.Concurrent.STM.TMVarIO as TIO import System.Posix.Types @@ -26,12 +27,20 @@ -- returns before the 'TMVar' is available, the 'TMVar' is guaranteed -- to be left in place. -- +-- See also 'selectOrReadTChan' and 'selectOrElse'. Note that +-- 'selectOrTakeTMVar' and the former are special cases of the latter. +-- -- (Incidentally, 'selectOrTakeTMVar' is the task I really wanted to -- accomplish, and solving it just turned into this little library). selectOrTakeTMVar :: [Fd] -> [Fd] -> [Fd] -> Timeout -> TMVar a -> IO (Either CInt a) -selectOrTakeTMVar readFds writeFds exceptFds timeout mv = TIO.runOrTakeTMVar (S.select readFds writeFds exceptFds timeout) mv +selectOrTakeTMVar readFds writeFds exceptFds timeout mv = selectOrElse readFds writeFds exceptFds timeout (takeTMVar mv) --- selectOrTakeTMVar :: [Fd] -> [Fd] -> [Fd] -> Timeout -> TMVar a -> IO (Either CInt a) --- selectOrTakeTMVar readFds writeFds exceptFds timeout tMVar1 = --- select readFds writeFds exceptFds timeout >>= \tMVar2 -> --- atomically ((Left <$> takeTMVar tMVar2) `orElse` (Right <$> takeTMVar tMVar1)) +-- | Analogous to 'selectOrTakeTMVar', except with a general STM +-- action in place of taking a 'TMVar'. +selectOrElse :: [Fd] -> [Fd] -> [Fd] -> Timeout -> STM a -> IO (Either CInt a) +selectOrElse readFds writeFds exceptFds timeout stm = ROE.runOrElse (S.select readFds writeFds exceptFds timeout) stm + +-- | Special case of 'selectOrElse' where the STM action is reading a +-- 'TChan'. +selectOrReadTChan :: [Fd] -> [Fd] -> [Fd] -> Timeout -> TChan a -> IO (Either CInt a) +selectOrReadTChan readFds writeFds exceptFds timeout tc = selectOrElse readFds writeFds exceptFds timeout (readTChan tc)