monadIO (empty) → 0.9.1.0

raw patch · 7 files changed

+668/−0 lines, 7 filesdep +basedep +mtldep +stmsetup-changed

Dependencies added: base, mtl, stm

Files

LICENSE +26/−0
Setup.hs +5/−0
monadIO.cabal +25/−0
src/Control/Concurrent/MonadIO.hs +197/−0
src/Control/Concurrent/STM/MonadIO.hs +229/−0
src/Control/Concurrent/StdInOut.hs +126/−0
src/Data/IORef/MonadIO.hs +60/−0

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright (c) 2008-2010, Galois, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS "AS IS" AND ANY EXPRESS OR IMPLIED+WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO+EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,5 @@+module Main where++import Distribution.Simple++main = defaultMain

+ monadIO.cabal view

@@ -0,0 +1,25 @@+name:               monadIO+version:            0.9.1.0+synopsis:           Overloading of concurrency variables+description:        MonadIO provides for many IO operations to be+                    overloaded over other IO-like monads.+category:           Concurrency+license:            BSD3+license-file:       LICENSE+author:             John Launchbury+maintainer:         John Launchbury+Copyright:          (c) 2008-2010, Galois, Inc.+cabal-version:      >= 1.2.0+build-type:         Simple+++Library+  Build-Depends:    base >= 4.2.0.0 && <= 4.3,+                    stm  >= 2.1.2.0 && <= 2.2,+                    mtl  >= 1.1.0.0 && <= 1.2+  Exposed-modules:  Control.Concurrent.MonadIO+                    Control.Concurrent.STM.MonadIO+                    Control.Concurrent.StdInOut+                    Data.IORef.MonadIO+  Hs-Source-Dirs:   src+  Ghc-Options:      -Wall

+ src/Control/Concurrent/MonadIO.hs view

@@ -0,0 +1,197 @@+--------------------------------------------------------------------------+{- |+Module      : Control.Concurrent.MonadIO+Copyright   : (c) 2010 Galois, Inc.+License     : BSD-style (see the file libraries/base/LICENSE)++Maintainer  : John Launchbury, john@galois.com+Stability   : experimental+Portability : concurrency++Overloads the standard operations on MVars, Chans, and threads,+as defined in Control.Concurrent. This module is name-for-name+swappable with Control.Concurrent unless ghc-specific +operations like 'mergeIO' or 'threadWaitRead' are used.++The standard operations on 'MVar' and 'Chan' (such as+'newEmptyMVar', or 'putChan') are overloaded over the+'MonadIO' class. A monad @m@ is declared an instance of+'MonadIO' by defining a function++> liftIO :: IO a -> m a++The explicit concurrency operations over threads are+available if a monad @m@ is declared an instance of the+'HasFork' class, by defining a function++> fork :: m () -> m ThreadId+++ * Example use.++Suppose you define a new monad (EIO say) which is like+'IO' except that it provides an environment too.+You will need to declare EIO and instance of the 'Monad' class. In +addition, you can declare it in the 'MonadIO' class. For example:++>  newtype EIO a = EIO {useEnv :: Env -> IO a}+>	+>  instance MonadIO EIO where+>    liftIO m = EIO $ (\_ -> m)++Now the standard operations on 'MVar' and 'Chan' (such as+'newEmptyMVar', or 'putChan' are immediately available as+EIO operations. To enable EIO to fork explicit threads, and to+access operations such as 'killThread' and 'threadDelay', use+the declaration++>  instance HasFork EIO where+>    fork em = EIO $ \e -> forkIO (em `useEnv` e)++++ * Notes.++The 'MVar' operations do not include: withMVar, modifyMVar, or +addMVarFinalizer. Consider using TMVars for these instead. In particular,+modifyMVar seems to promise atomicity, but it is NOT atomic. In+contrast TMVars can be used just like MVars, and they+will behave the way you expect (module Control.Concurrent.STM.MonadIO).++-}++++--------------------------------------------------------------------------+++{-# OPTIONS_GHC -fno-warn-unused-do-bind     #-}+++module Control.Concurrent.MonadIO (+    MonadIO(..)+    +  , C.MVar+  , newEmptyMVar+  , newMVar+  , takeMVar+  , putMVar+  , readMVar+  , swapMVar+  , tryTakeMVar+  , tryPutMVar+  , isEmptyMVar+  +  , C.Chan+  , newChan+  , writeChan+  , readChan+  , dupChan+  , unGetChan+  , isEmptyChan+  , getChanContents+  , writeList2Chan+  +  , HasFork(..)+  , C.ThreadId+  , forkIO+  , myThreadId+  , killThread+  , throwTo+  , yield+  , threadDelay+  +  )+  where++import Control.Monad.Trans(MonadIO(..))+import qualified Control.Concurrent as C+import qualified Control.Exception as E++++newEmptyMVar  :: MonadIO io => io (C.MVar a)+newEmptyMVar   = liftIO $ C.newEmptyMVar++newMVar       :: MonadIO io => a -> io (C.MVar a)+newMVar x      = liftIO $ C.newMVar x++takeMVar      :: MonadIO io => C.MVar a -> io a+takeMVar m     = liftIO $ C.takeMVar m++putMVar       :: MonadIO io => C.MVar a -> a -> io ()+putMVar m x    = liftIO $ C.putMVar m x++readMVar      :: MonadIO io => C.MVar a -> io a+readMVar m     = liftIO $ C.readMVar m++swapMVar      :: MonadIO io => C.MVar a -> a -> io a+swapMVar m x   = liftIO $ C.swapMVar m x ++tryTakeMVar   :: MonadIO io => C.MVar a -> io (Maybe a)+tryTakeMVar m  = liftIO $ C.tryTakeMVar m++tryPutMVar    :: MonadIO io => C.MVar a -> a -> io Bool+tryPutMVar m x = liftIO $ C.tryPutMVar m x++isEmptyMVar   :: MonadIO io => C.MVar a -> io Bool+isEmptyMVar m  = liftIO $ C.isEmptyMVar m++++-------------------------------------------------------------------------++newChan            :: MonadIO io => io (C.Chan a)+newChan             = liftIO $ C.newChan++writeChan          :: MonadIO io => C.Chan a -> a -> io ()+writeChan c x       = liftIO $ C.writeChan c x++readChan           :: MonadIO io => C.Chan a -> io a+readChan c          = liftIO $ C.readChan c++dupChan            :: MonadIO io => C.Chan a -> io (C.Chan a)+dupChan c           = liftIO $ C.dupChan c ++unGetChan          :: MonadIO io => C.Chan a -> a -> io ()+unGetChan c x       = liftIO $ unGetChan c x++isEmptyChan        :: MonadIO io => C.Chan a -> io Bool+isEmptyChan c       = liftIO $ C.isEmptyChan c++getChanContents    :: MonadIO io => C.Chan a -> io [a]+getChanContents c   = liftIO $ C.getChanContents c++writeList2Chan     :: MonadIO io => C.Chan a -> [a] -> io ()+writeList2Chan c xs = liftIO $ C.writeList2Chan c xs+++-------------------------------------------------------------------------++class MonadIO io => HasFork io where+  fork :: io () -> io C.ThreadId++instance HasFork IO where+  fork m = C.forkIO m++-- | Included to maintain name-for-name compatibility+--   with Control.Concurrent+forkIO :: IO () -> IO C.ThreadId+forkIO = C.forkIO++myThreadId   :: HasFork io => io C.ThreadId+myThreadId    = liftIO $ C.myThreadId++killThread   :: HasFork io => C.ThreadId -> io ()+killThread i  = liftIO $ C.killThread i++throwTo      :: (E.Exception e, HasFork io) => C.ThreadId -> e -> io ()+throwTo i e   = liftIO $ C.throwTo i e++yield        :: HasFork io => io ()+yield         = liftIO $ C.yield++threadDelay  :: HasFork io => Int -> io ()+threadDelay n = liftIO $ C.threadDelay n++

+ src/Control/Concurrent/STM/MonadIO.hs view

@@ -0,0 +1,229 @@+--------------------------------------------------------------------------+{- |+Module      : Control.Concurrent.STM.MonadIO+Copyright   : (c) 2010 Galois, Inc.+License     : BSD-style (see the file libraries/base/LICENSE)++Maintainer  : John Launchbury, john@galois.com+Stability   : experimental+Portability : concurrency, requires STM++Overloads the standard operations on TVars, and TMVars as defined+in Control.Concurrent.STM.++TVars and MVars are often thought of as variables to be +used in the STM monad. But in practice, they should be used+just as frequently (if not more so) in any IO-like monad, with STM +being used purely when a new atomic transaction is being defined.+Thus we reverse the naming convention, and use+the plain access names when in the IO-like monad, and use an explicit STM +suffix when using the variables tentatively within the STM monad itself.++TMVars are particularly valuable when used in an IO-like monad,+because operations like readTMVar and modifyTMvar+can guarantee the atomicity of the operation (unlike the corresponding+operations over MVars).++The standard operations on 'TVar' and 'TMVar' (such as+'writeTVar' or 'newEmptyTMVar') are overloaded over the+'MonadIO' class. A monad @m@ is declared an instance of+'MonadIO' by defining a function++> liftIO :: IO a -> m a++It also overloads the 'atomically' function, so that STM transactions+can be defined from within any MonadIO monad.++-}++{-# OPTIONS_GHC -fno-warn-unused-do-bind     #-}++++module Control.Concurrent.STM.MonadIO (++    STM+  , atomically+  , always+  , alwaysSucceeds+  , retry +  , orElse +  , check +  , catchSTM ++  , S.TVar+  , newTVar+  , readTVar+  , writeTVar+  , registerDelay+  , modifyTVar+  , modifyTVar_++  , newTVarSTM+  , readTVarSTM+  , writeTVarSTM+++  , S.TMVar+  , newTMVar+  , newEmptyTMVar+  , takeTMVar+  , putTMVar+  , readTMVar+  , swapTMVar+  , tryTakeTMVar+  , tryPutTMVar+  , isEmptyTMVar+  , modifyTMVar +  , modifyTMVar_ ++  , newTMVarSTM+  , newEmptyTMVarSTM+  , takeTMVarSTM+  , putTMVarSTM+  , readTMVarSTM+  , swapTMVarSTM+  , tryTakeTMVarSTM+  , tryPutTMVarSTM+  , isEmptyTMVarSTM+  )+  where++import Control.Monad.STM hiding (atomically)+import qualified Control.Concurrent.STM as S+import Control.Concurrent.MonadIO++import GHC.Conc (readTVarIO)+++-------------------------------------------------------------------------+-- | The atomically function allows STM to be called directly from any+-- monad which contains IO, i.e. is a member of MonadIO.++atomically :: MonadIO io => STM a -> io a+atomically m = liftIO $ S.atomically m++-------------------------------------------------------------------------+++type TVar = S.TVar++newTVar      :: MonadIO io => a -> io (TVar a)+newTVar x     = liftIO $ S.newTVarIO x++readTVar     :: MonadIO io => TVar a -> io a+readTVar t    = liftIO $ readTVarIO t++writeTVar    :: MonadIO io => TVar a -> a -> io ()+writeTVar t x = atomically $ writeTVarSTM t x++registerDelay :: MonadIO io => Int -> io (TVar Bool)+registerDelay n = liftIO $ S.registerDelay n++-- | 'modifyTVar' is an atomic update operation which provides both+-- the former value and the newly computed value as a result.++modifyTVar :: MonadIO io => TVar a -> (a -> a) -> io (a,a)+modifyTVar t f = atomically $ do+                    x <- readTVarSTM t+                    let y = f x+                    seq y $ writeTVarSTM t y+                    return (x,y)++modifyTVar_ :: MonadIO io => TVar a -> (a -> a) -> io ()+modifyTVar_ t f = atomically $ do+                    x <- readTVarSTM t+                    let y = f x+                    seq y $ writeTVarSTM t y++----------------------+++newTVarSTM :: a -> STM (TVar a)+newTVarSTM x = S.newTVar x++readTVarSTM :: TVar a -> STM a+readTVarSTM t = S.readTVar t++writeTVarSTM :: TVar a -> a -> STM ()+writeTVarSTM t x = S.writeTVar t x+++++-------------------------------------------------------------------------++type TMVar a = S.TMVar a++newTMVar :: MonadIO io => a -> io (TMVar a)+newTMVar x = liftIO $ S.newTMVarIO x++newEmptyTMVar :: MonadIO io => io (TMVar a)+newEmptyTMVar = liftIO $ S.newEmptyTMVarIO++takeTMVar :: MonadIO io => TMVar a -> io a+takeTMVar t = atomically $ takeTMVarSTM t++putTMVar :: MonadIO io => TMVar a -> a -> io ()+putTMVar t x  = atomically $ putTMVarSTM t x++readTMVar :: MonadIO io => TMVar a -> io a+readTMVar t = atomically $ readTMVarSTM t++swapTMVar :: MonadIO io => TMVar a -> a -> io a+swapTMVar t x = atomically $ swapTMVarSTM t x++tryTakeTMVar :: MonadIO io => TMVar a -> io (Maybe a)+tryTakeTMVar t = atomically $ tryTakeTMVarSTM t++tryPutTMVar :: MonadIO io => TMVar a -> a -> io Bool+tryPutTMVar t x = atomically $ tryPutTMVarSTM t x++isEmptyTMVar :: MonadIO io => TMVar a -> io Bool+isEmptyTMVar t = atomically $ isEmptyTMVarSTM t++-- modifyTMVar is an atomic update operation which provides both+-- the former value and the newly computed value as a result.++modifyTMVar :: MonadIO io => TMVar a -> (a -> a) -> io (a,a)+modifyTMVar t f = atomically $ do+                    x <- takeTMVarSTM t+                    let y = f x+                    seq y $ putTMVarSTM t y+                    return (x,y)++modifyTMVar_ :: MonadIO io => TMVar a -> (a -> a) -> io ()+modifyTMVar_ t f = atomically $ do+                    x <- takeTMVarSTM t+                    let y = f x+                    seq y $ putTMVarSTM t y++----------------------++newTMVarSTM :: a -> STM (TMVar a)+newTMVarSTM = S.newTMVar++newEmptyTMVarSTM :: STM (TMVar a)+newEmptyTMVarSTM = S.newEmptyTMVar++takeTMVarSTM :: TMVar a -> STM a+takeTMVarSTM = S.takeTMVar++putTMVarSTM :: TMVar a -> a -> STM ()+putTMVarSTM = S.putTMVar++readTMVarSTM :: TMVar a -> STM a+readTMVarSTM = S.readTMVar++swapTMVarSTM :: TMVar a -> a -> STM a+swapTMVarSTM = S.swapTMVar++tryTakeTMVarSTM :: TMVar a -> STM (Maybe a)+tryTakeTMVarSTM = S.tryTakeTMVar++tryPutTMVarSTM :: TMVar a -> a -> STM Bool+tryPutTMVarSTM = S.tryPutTMVar++isEmptyTMVarSTM :: TMVar a -> STM Bool+isEmptyTMVarSTM = S.isEmptyTMVar+

+ src/Control/Concurrent/StdInOut.hs view

@@ -0,0 +1,126 @@+--------------------------------------------------------------------------+{- |+Module      : Control.Concurrent.StdInOut+Copyright   : (c) 2010 Galois, Inc.+License     : BSD-style (see the file libraries/base/LICENSE)++Maintainer  : John Launchbury, john@galois.com+Stability   : experimental+Portability : concurrency++A low-tech concurrent interface to the console. When multiple threads+want input, they send messages to the console with the format++>  <thread-id>:request++The user supplies input to any requesting thread in a similar way:++>  <thread-id>:response++At any time, the user can enter @!!@ to obtain a listing of all the+active prompts. Any input not of either of these forms is discarded.++> example :: IO ()+> example = setupStdinout processes+> +> processes :: IO ()+> processes = do+>     forkIO $ (prompt "Enter something" >> return ())+>     forkIO $ (prompt "Something else" >> return ())+>     prompt "quit"      -- When the main thread dies,+>     return ()          -- the whole interaction ends++-}++--------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Control.Concurrent.StdInOut+  ( setupStdInOut  -- :: IO a -> IO a+  , prompt         -- :: String -> IO String+  , putStrLine     -- :: String -> IO ()+  ) where+++import System.IO(hSetBuffering,BufferMode(..),stdout)+import System.IO.Unsafe(unsafePerformIO) -- for a global variable+import Control.Monad(forever,join)+import Control.Exception(finally)++import Control.Concurrent.MonadIO++import Control.Concurrent.STM.MonadIO+++flag :: String+flag = "!!"                          -- User input to list active prompts+timeDelay :: Int+timeDelay = 100000                   -- 1/10th sec+++-- 'std' is a concurrent variable that holds the current input line for+-- other processes to consider whether they want to grab it. The+-- process 'forever inputScan' maintains it.++type Stdinout = TMVar String++{-# NOINLINE std #-}+std :: Stdinout+std = unsafePerformIO $ newEmptyTMVar  -- global location for input strings++-- | 'setupStdInOut' establishes the context for 'prompt', by running+--   a daemon while its argument is executing. The daemon is terminated+--   once the argument to 'setupStdInOut' finishes.++setupStdInOut :: IO a -> IO a+setupStdInOut procs = do+    hSetBuffering stdout LineBuffering   -- prevents character interleaving+    tid <- fork $ forever inputScan      -- daemon putting stdin into std+    procs `finally` killThread tid++inputScan :: IO (Maybe String)+inputScan = do+    str <- getLine                       -- get next input line from stdin+    putTMVar std str                     -- make the input available to others+    threadDelay timeDelay                -- give others time to grab it+    tryTakeTMVar std                     -- clear the input if still present+++-- | 'prompt' is the main user level function of the module. The function+-- prints its argument on stdout, prefixed by its process number. The user +-- similarly selects the recipient by prefixing the process number,+-- e.g. "23:". Active prompts will reprompt when !! is entered. ++prompt :: HasFork io => String -> io String+prompt text = do+    name <- myThreadNumber+    putStrLine (name ++ text)+    (join . atomically) $ do+       str <- takeTMVarSTM std           -- Grab the input string to examine+       case match name str of+         Just inp -> return (return inp) -- Exit with the string contents+         Nothing -> do+            check (str==flag)            -- Test whether to reprint the prompt+            putTMVarSTM std flag         -- Replace the flag for others to see+            return $ do+               threadDelay (2*timeDelay) -- Wait for the flag to flush+               prompt text               -- Recurse, to reprint the prompt++myThreadNumber :: HasFork io => io String+myThreadNumber = do+    tid <- myThreadId+    return $ drop (length "ThreadId ") (show tid ++ ":")++match :: String -> String -> Maybe String+match n s = if n == take (length n) s then+              Just (drop (length n) s)+            else+              Nothing++-- | 'putStrLine' sends output to stdout, ensuring that lines are whole+-- and uninterrupted (including the final newline).++putStrLine :: MonadIO io => String -> io ()+putStrLine s = liftIO $ putStr (s ++ "\n")  +

+ src/Data/IORef/MonadIO.hs view

@@ -0,0 +1,60 @@+--------------------------------------------------------------------------+{- |+Module      : Data.IORef.MonadIO+Copyright   : (c) 2010 Galois, Inc.+License     : BSD-style (see the file libraries/base/LICENSE)++Maintainer  : John Launchbury, john@galois.com+Stability   : experimental+Portability : IO++Overloads the standard operations on IORefs,+as defined in Data.IORef. This module is name-for-name+swappable with Data.IORef unless ghc-specific +operations like weak pointers are used.++The standard operations on 'IORef' (such as+'newIORef', or 'modifyIORef') are overloaded over the+'MonadIO' class. A monad @m@ is declared an instance of+'MonadIO' by defining a function++> liftIO :: IO a -> m a++-}++--------------------------------------------------------------------------++++module Data.IORef.MonadIO (+    MonadIO(..)+    +  , R.IORef+  , newIORef+  , readIORef+  , writeIORef+  , modifyIORef+  , atomicModifyIORef+  +  )+  where++import Control.Monad.Trans(MonadIO(..))+import qualified Data.IORef as R+++newIORef :: MonadIO io => a -> io (R.IORef a)+newIORef x = liftIO $ R.newIORef x++readIORef :: MonadIO io => R.IORef a -> io a+readIORef r = liftIO $ R.readIORef r++writeIORef :: MonadIO io => R.IORef a -> a -> io ()+writeIORef r x = liftIO $ R.writeIORef r x++modifyIORef :: MonadIO io => R.IORef a -> (a -> a) -> io ()+modifyIORef r f = liftIO $ R.modifyIORef r f++atomicModifyIORef :: MonadIO io => R.IORef a -> (a -> (a, b)) -> io b+atomicModifyIORef r f = liftIO $ R.atomicModifyIORef r f+