diff --git a/Access/Control/Concurrent.hs b/Access/Control/Concurrent.hs --- a/Access/Control/Concurrent.hs +++ b/Access/Control/Concurrent.hs @@ -1,9 +1,20 @@ {-# LANGUAGE RankNTypes #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Access.Control.Concurrent +-- Copyright : (c) Aaron Stevens, 2014 +-- License : GPL2 +-- +-- Maintainer : bheklilr2@gmail.com +-------------------------------------------------------------------------------- + module Access.Control.Concurrent ( module Control.Concurrent , module Access.Control.Concurrent.MVar , module Access.Control.Concurrent.Chan + , module Access.Control.Concurrent.QSem + , module Access.Control.Concurrent.QSemN , ThreadAccess(..) , BoundThreadAccess(..) @@ -11,42 +22,312 @@ ) where -import Control.Concurrent -import System.Posix.Types (Fd) +import Control.Concurrent +import GHC.Conc (STM) +import System.Posix.Types (Fd) -import Access.System.Mem.Weak -import Access.Control.Exception -import Access.Control.Concurrent.MVar -import Access.Control.Concurrent.Chan +import Access.Control.Concurrent.Chan +import Access.Control.Concurrent.MVar +import Access.Control.Concurrent.QSem +import Access.Control.Concurrent.QSemN +import Access.Control.Exception +import Access.System.Mem.Weak +-- | Inherits from 'ExceptionAccess', and gives access to Thread related functions class ExceptionAccess io => ThreadAccess io where + -- | Wraps 'Control.Concurrent.myThreadId' + -- + -- Returns the 'ThreadId' of the calling thread (GHC only) myThreadId' :: io ThreadId + -- | Wraps 'Control.Concurrent.forkIO' + -- + -- Sparks off a new thread to run the 'IO' computation passed as the + -- first argument, and returns the 'ThreadId' of the newly created + -- thread. + -- + -- The new thread will be a lightweight thread; if you want to use a foreign + -- library that uses thread-local storage, use 'forkOS'' instead. + -- + -- GHC note: the new thread inherits the /masked/ state of the parent + -- (see 'Access.Control.Exception.mask''). + -- + -- The newly created thread has an exception handler that discards the + -- exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and + -- 'ThreadKilled', and passes all other exceptions to the uncaught + -- exception handler. forkIO' :: io () -> io ThreadId + -- | Wraps 'Control.Concurrent.forkFinally' + -- + -- Fork a thread and call the supplied function when the thread is about + -- to terminate, with an exception or a returned value. The function is + -- called with asynchronous exceptions masked. + -- + -- > forkFinally' action and_then = + -- > mask $ \restore -> + -- > forkIO' $ try (restore action) >>= and_then + -- + -- This function is useful for informing the parent when a child + -- terminates, for example. forkFinally' :: io a -> (Either SomeException a -> io ()) -> io ThreadId + -- | Wraps 'Control.Concurrent.forkIOWithUnmask' + -- + -- Like 'forkIO'', but the child thread is passed a function that can + -- be used to unmask asynchronous exceptions. This function is + -- typically used in the following way + -- + -- > ... mask_ $ forkIOWithUnmask' $ \unmask -> + -- > catch' (unmask ...) handler + -- + -- so that the exception handler in the child thread is established + -- with asynchronous exceptions masked, meanwhile the main body of + -- the child thread is executed in the unmasked state. + -- + -- Note that the unmask function passed to the child thread should + -- only be used in that thread; the behaviour is undefined if it is + -- invoked in a different thread. forkIOWithUnmask' :: ((forall a. io a -> io a) -> io ()) -> io ThreadId + -- | Wraps 'Control.Concurrent.killThread' + -- + -- 'killThread'' raises the 'ThreadKilled' exception in the given + -- thread (GHC only). + -- + -- > killThread' tid = throwTo' tid ThreadKilled killThread' :: ThreadId -> io () + -- | Wraps 'Control.Concurrent.throwTo' + -- + -- 'throwTo'' raises an arbitrary exception in the target thread (GHC only). + -- + -- 'throwTo'' does not return until the exception has been raised in the + -- target thread. + -- The calling thread can thus be certain that the target + -- thread has received the exception. This is a useful property to know + -- when dealing with race conditions: eg. if there are two threads that + -- can kill each other, it is guaranteed that only one of the threads + -- will get to kill the other. + -- + -- Whatever work the target thread was doing when the exception was + -- raised is not lost: the computation is suspended until required by + -- another thread. + -- + -- If the target thread is currently making a foreign call, then the + -- exception will not be raised (and hence 'throwTo'' will not return) + -- until the call has completed. This is the case regardless of whether + -- the call is inside a 'mask'' or not. However, in GHC a foreign call + -- can be annotated as @interruptible@, in which case a 'throwTo'' will + -- cause the RTS to attempt to cause the call to return; see the GHC + -- documentation for more details. + -- + -- Important note: the behaviour of 'throwTo'' differs from that described in + -- the paper \"Asynchronous exceptions in Haskell\" + -- (). + -- In the paper, 'throwTo'' is non-blocking; but the library implementation + -- adopts a more synchronous design in which 'throwTo'' does not return + -- until the exception is received by the target thread. The trade-off is + -- discussed in Section 9 of the paper. Like any blocking operation, + -- 'throwTo'' is therefore interruptible (see Section 5.3 of the paper). + -- Unlike other interruptible operations, however, 'throwTo'' is /always/ + -- interruptible, even if it does not actually block. + -- + -- There is no guarantee that the exception will be delivered promptly, + -- although the runtime will endeavour to ensure that arbitrary + -- delays don't occur. In GHC, an exception can only be raised when a + -- thread reaches a /safe point/, where a safe point is where memory + -- allocation occurs. Some loops do not perform any memory allocation + -- inside the loop and therefore cannot be interrupted by a 'throwTo''. + -- + -- If the target of 'throwTo'' is the calling thread, then the behaviour + -- is the same as 'Access.Control.Exception.throwIO'', except that the + -- exception is thrown as an asynchronous exception. This means that if + -- there is an enclosing pure computation, which would be the case if the + -- current IO operation is inside 'unsafePerformIO' or 'unsafeInterleaveIO', + -- that computation is not permanently replaced by the exception, but is + -- suspended as if it had received an asynchronous exception. + -- + -- Note that if 'throwTo'' is called with the current thread as the + -- target, the exception will be thrown even if the thread is currently + -- inside 'mask'' or 'uninterruptibleMask''. throwTo' :: Exception e => ThreadId -> e -> io () throwTo' = Access.Control.Exception.throwTo' + -- | Wraps 'Control.Concurrent.forkOn' + -- + -- Like ''forkIO'', but lets you specify on which processor the thread + -- should run. Unlike a `'forkIO'` thread, a thread created by `forkOn'` + -- will stay on the same processor for its entire lifetime (`'forkIO'` + -- threads can migrate between processors according to the scheduling + -- policy). `forkOn'` is useful for overriding the scheduling policy when + -- you know in advance how best to distribute the threads. + -- + -- The `Int` argument specifies a /capability number/ (see + -- 'getNumCapabilities''). Typically capabilities correspond to physical + -- processors, but the exact behaviour is implementation-dependent. The + -- value passed to 'forkOn'' is interpreted modulo the total number of + -- capabilities as returned by 'getNumCapabilities''. + -- + -- GHC note: the number of capabilities is specified by the @+RTS -N@ + -- option when the program is started. Capabilities can be fixed to + -- actual processor cores with @+RTS -qa@ if the underlying operating + -- system supports that, although in practice this is usually unnecessary + -- (and may actually degrade perforamnce in some cases - experimentation + -- is recommended). forkOn' :: Int -> io () -> io ThreadId + -- | Wraps 'Control.Concurrent.forkOnWithUnmask' + -- + -- Like 'forkIOWithUnmask'', but the child thread is pinned to the + -- given CPU, as with 'forkOn''. forkOnWithUnmask' :: Int -> ((forall a. io a -> io a) -> io ()) -> io ThreadId + -- | Wraps 'Control.Concurrent.getNumCapabilities' + -- + -- Returns the number of Haskell threads that can run truly + -- simultaneously (on separate physical processors) at any given time. To + -- change this value, use 'setNumCapabilities''. getNumCapabilities' :: io Int + -- | Wraps 'Control.Concurrent.setNumCapabilities' + -- + -- Set the number of Haskell threads that can run truly simultaneously + -- (on separate physical processors) at any given time. The number + -- passed to `forkOn'` is interpreted modulo this value. The initial + -- value is given by the @+RTS -N@ runtime flag. + -- + -- This is also the number of threads that will participate in parallel + -- garbage collection. It is strongly recommended that the number of + -- capabilities is not set larger than the number of physical processor + -- cores, and it may often be beneficial to leave one or more cores free + -- to avoid contention with other processes in the machine. setNumCapabilities' :: Int -> io () + -- | Wraps 'Control.Concurrent.threadCapability' + -- + -- Returns the number of the capability on which the thread is currently + -- running, and a boolean indicating whether the thread is locked to + -- that capability or not. A thread is locked to a capability if it + -- was created with @forkOn'@. threadCapability' :: ThreadId -> io (Int, Bool) + -- | Wraps 'Control.Concurrent.yield' + -- + -- The 'yield'' action allows (forces, in a co-operative multitasking + -- implementation) a context-switch to any other currently runnable + -- threads (if any), and is occasionally useful when implementing + -- concurrency abstractions. yield' :: io () + -- | Wraps 'Control.Concurrent.threadDelay' + -- + -- Suspends the current thread for a given number of microseconds + -- (GHC only). + -- + -- There is no guarantee that the thread will be rescheduled promptly + -- when the delay has expired, but the thread will never continue to + -- run /earlier/ than specified. threadDelay' :: Int -> io () + -- | Wraps 'Control.Concurrent.threadWaitRead' + -- + -- Block the current thread until data is available to read on the + -- given file descriptor (GHC only). + -- + -- This will throw an 'IOError' if the file descriptor was closed + -- while this thread was blocked. To safely close a file descriptor + -- that has been used with 'threadWaitRead', use + -- 'GHC.Conc.closeFdWith'. threadWaitRead' :: Fd -> io () + -- | Wraps 'Control.Concurrent.threadWaitWrite' + -- + -- Block the current thread until data can be written to the + -- given file descriptor (GHC only). + -- + -- This will throw an 'IOError' if the file descriptor was closed + -- while this thread was blocked. To safely close a file descriptor + -- that has been used with 'threadWaitWrite', use + -- 'GHC.Conc.closeFdWith'. threadWaitWrite' :: Fd -> io () + -- | Returns an STM action that can be used to wait for data + -- to read from a file descriptor. The second returned value + -- is an IO action that can be used to deregister interest + -- in the file descriptor. + -- + -- /Since: 4.7.0.0/ + threadWaitReadSTM' :: Fd -> io (STM (), io ()) + -- | Returns an STM action that can be used to wait until data + -- can be written to a file descriptor. The second returned value + -- is an IO action that can be used to deregister interest + -- in the file descriptor. + -- + -- /Since: 4.7.0.0/ + threadWaitWriteSTM' :: Fd -> io (STM (), io ()) +-- | Provides access to bounded thread functions class ThreadAccess io => BoundThreadAccess io where + -- | Wraps 'Control.Concurrent.forkOS' + -- + -- Like 'forkIO'', this sparks off a new thread to run the 'IO' + -- computation passed as the first argument, and returns the 'ThreadId' + -- of the newly created thread. + -- + -- However, 'forkOS'' creates a /bound/ thread, which is necessary if you + -- need to call foreign (non-Haskell) libraries that make use of + -- thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads"). + -- + -- Using 'forkOS'' instead of 'forkIO'' makes no difference at all to the + -- scheduling behaviour of the Haskell runtime system. It is a common + -- misconception that you need to use 'forkOS'' instead of 'forkIO'' to + -- avoid blocking all the Haskell threads when making a foreign call; + -- this isn't the case. To allow foreign calls to be made without + -- blocking all the Haskell threads (with GHC), it is only necessary to + -- use the @-threaded@ option when linking your program, and to make sure + -- the foreign import is not marked @unsafe@. forkOS' :: io () -> io ThreadId + -- | Wraps 'Control.Concurrent.isCurrentThreadBound' + -- + -- Returns 'True' if the calling thread is /bound/, that is, if it is + -- safe to use foreign libraries that rely on thread-local state from the + -- calling thread. isCurrentThreadBound' :: io Bool + -- | Wraps 'Control.Concurrent.runInBoundThread' + -- + -- Run the 'IO' computation passed as the first argument. If the calling + -- thread is not /bound/, a bound thread is created temporarily. + -- @runInBoundThread'@ doesn't finish until the 'IO' computation finishes. + -- + -- You can wrap a series of foreign function calls that rely on thread-local + -- state with @runInBoundThread'@ so that you can use them without knowing + -- whether the current thread is /bound/. runInBoundThread' :: io a -> io a + -- | Wraps 'Control.Concurrent.runInUnboundThread' + -- + --Run the 'IO' computation passed as the first argument. If the calling + -- thread is /bound/, an unbound thread is created temporarily using + -- 'forkIO''. @runInBoundThread'@ doesn't finish until the 'IO' computation + -- finishes. + -- + -- Use this function /only/ in the rare case that you have actually observed + -- a performance loss due to the use of bound threads. A program that + -- doesn't need it's main thread to be bound and makes /heavy/ use of + -- concurrency (e.g. a web server), might want to wrap it's @main@ action in + -- @runInUnboundThread'@. + -- + -- Note that exceptions which are thrown to the current thread are thrown in + -- turn to the thread that is executing the given computation. This ensures + -- there's always a way of killing the forked thread. runInUnboundThread' :: io a -> io a +-- | Provides access to the 'mkWeakThreadId' function, inherits from 'WeakMemAccess' class WeakMemAccess io => WeakThreadAccess io where + -- | Wraps 'Control.Concurrent.mkWeakThreadId' + -- + -- Make a weak pointer to a 'ThreadId'. It can be important to do + -- this if you want to hold a reference to a 'ThreadId' while still + -- allowing the thread to receive the @BlockedIndefinitely@ family of + -- exceptions (e.g. 'BlockedIndefinitelyOnMVar'). Holding a normal + -- 'ThreadId' reference will prevent the delivery of + -- @BlockedIndefinitely@ exceptions because the reference could be + -- used as the target of 'throwTo'' at any time, which would unblock + -- the thread. + -- + -- Holding a @Weak ThreadId@, on the other hand, will not prevent the + -- thread from receiving @BlockedIndefinitely@ exceptions. It is + -- still possible to throw an exception to a @Weak ThreadId@, but the + -- caller must use @deRefWeak'@ first to determine whether the thread + -- still exists. mkWeakThreadId' :: ThreadId -> io (Weak ThreadId) @@ -66,6 +347,8 @@ threadDelay' = threadDelay threadWaitRead' = threadWaitRead threadWaitWrite' = threadWaitWrite + threadWaitReadSTM' = threadWaitReadSTM + threadWaitWriteSTM' = threadWaitWriteSTM instance BoundThreadAccess IO where forkOS' = forkOS diff --git a/Access/Control/Concurrent/Chan.hs b/Access/Control/Concurrent/Chan.hs --- a/Access/Control/Concurrent/Chan.hs +++ b/Access/Control/Concurrent/Chan.hs @@ -5,17 +5,30 @@ ) where -import Control.Concurrent.Chan +import Control.Concurrent.Chan -import Access.Core +import Access.Core class Access io => ChanAccess io where + -- |Build and returns a new instance of 'Chan'. newChan' :: io (Chan a) + -- |Write a value to a 'Chan'. writeChan' :: Chan a -> a -> io () + -- |Read the next value from the 'Chan'. readChan' :: Chan a -> io a + -- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to + -- either channel from then on will be available from both. Hence this creates + -- a kind of broadcast channel, where data written by anyone is seen by + -- everyone else. + -- + -- (Note that a duplicated channel is not equal to its original. + -- So: @fmap (c /=) $ dupChan c@ returns @True@ for all @c@.) dupChan' :: Chan a -> io (Chan a) + -- |Return a lazy list representing the contents of the supplied + -- 'Chan', much like 'System.IO.hGetContents'. getChanContents' :: Chan a -> io [a] + -- |Write an entire list of items to a 'Chan'. writeList2Chan' :: Chan a -> [a] -> io () diff --git a/Access/Control/Concurrent/MVar.hs b/Access/Control/Concurrent/MVar.hs --- a/Access/Control/Concurrent/MVar.hs +++ b/Access/Control/Concurrent/MVar.hs @@ -6,28 +6,146 @@ ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar -import Access.Core -import Access.System.Mem.Weak +import Access.Core +import Access.System.Mem.Weak class Access io => MVarAccess io where + -- |Create an 'MVar' which is initially empty. newEmptyMVar' :: io (MVar a) + -- |Create an 'MVar' which contains the supplied value. newMVar' :: a -> io (MVar a) + -- |Return the contents of the 'MVar'. If the 'MVar' is currently + -- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', + -- the 'MVar' is left empty. + -- + -- There are two further important properties of 'takeMVar': + -- + -- * 'takeMVar' is single-wakeup. That is, if there are multiple + -- threads blocked in 'takeMVar', and the 'MVar' becomes full, + -- only one thread will be woken up. The runtime guarantees that + -- the woken thread completes its 'takeMVar' operation. + -- + -- * When multiple threads are blocked on an 'MVar', they are + -- woken up in FIFO order. This is useful for providing + -- fairness properties of abstractions built using 'MVar's. + -- takeMVar' :: MVar a -> io a + -- |Put a value into an 'MVar'. If the 'MVar' is currently full, + -- 'putMVar' will wait until it becomes empty. + -- + -- There are two further important properties of 'putMVar': + -- + -- * 'putMVar' is single-wakeup. That is, if there are multiple + -- threads blocked in 'putMVar', and the 'MVar' becomes empty, + -- only one thread will be woken up. The runtime guarantees that + -- the woken thread completes its 'putMVar' operation. + -- + -- * When multiple threads are blocked on an 'MVar', they are + -- woken up in FIFO order. This is useful for providing + -- fairness properties of abstractions built using 'MVar's. + -- putMVar' :: MVar a -> a -> io () + -- |Atomically read the contents of an 'MVar'. If the 'MVar' is + -- currently empty, 'readMVar' will wait until its full. + -- 'readMVar' is guaranteed to receive the next 'putMVar'. + -- + -- 'readMVar' is multiple-wakeup, so when multiple readers are + -- blocked on an 'MVar', all of them are woken up at the same time. + -- + -- /Compatibility note:/ Prior to base 4.7, 'readMVar' was a combination + -- of 'takeMVar' and 'putMVar'. This mean that in the presence of + -- other threads attempting to 'putMVar', 'readMVar' could block. + -- Furthermore, 'readMVar' would not receive the next 'putMVar' if there + -- was already a pending thread blocked on 'takeMVar'. The old behavior + -- can be recovered by implementing 'readMVar as follows: + -- + -- @ + -- readMVar :: MVar a -> IO a + -- readMVar m = + -- mask_ $ do + -- a <- takeMVar m + -- putMVar m a + -- return a + -- @ readMVar' :: MVar a -> io a + {-| + Take a value from an 'MVar', put a new value into the 'MVar' and + return the value taken. This function is atomic only if there are + no other producers for this 'MVar'. + -} swapMVar' :: MVar a -> a -> io a + -- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function + -- returns immediately, with 'Nothing' if the 'MVar' was empty, or + -- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', + -- the 'MVar' is left empty. tryTakeMVar' :: MVar a -> io (Maybe a) + -- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function + -- attempts to put the value @a@ into the 'MVar', returning 'True' if + -- it was successful, or 'False' otherwise. tryPutMVar' :: MVar a -> a -> io Bool + -- |A non-blocking version of 'readMVar'. The 'tryReadMVar' function + -- returns immediately, with 'Nothing' if the 'MVar' was empty, or + -- @'Just' a@ if the 'MVar' was full with contents @a@. + -- + -- /Since: 4.7.0.0/ + tryReadMVar' :: MVar a -> io (Maybe a) + -- |Check whether a given 'MVar' is empty. + -- + -- Notice that the boolean value returned is just a snapshot of + -- the state of the MVar. By the time you get to react on its result, + -- the MVar may have been filled (or emptied) - so be extremely + -- careful when using this operation. Use 'tryTakeMVar' instead if possible. isEmptyMVar' :: MVar a -> io Bool + {-| + 'withMVar' is an exception-safe wrapper for operating on the contents + of an 'MVar'. This operation is exception-safe: it will replace the + original contents of the 'MVar' if an exception is raised (see + "Control.Exception"). However, it is only atomic if there are no + other producers for this 'MVar'. + -} withMVar' :: MVar a -> (a -> IO b) -> io b + {-| + Like 'withMVar', but the @IO@ action in the second argument is executed + with asynchronous exceptions masked. + + /Since: 4.7.0.0/ + -} + withMVarMasked' :: MVar a -> (a -> IO b) -> io b + {-| + An exception-safe wrapper for modifying the contents of an 'MVar'. + Like 'withMVar', 'modifyMVar' will replace the original contents of + the 'MVar' if an exception is raised during the operation. This + function is only atomic if there are no other producers for this + 'MVar'. + -} modifyMVar_' :: MVar a -> (a -> IO a) -> io () + {-| + A slight variation on 'modifyMVar_' that allows a value to be + returned (@b@) in addition to the modified value of the 'MVar'. + -} modifyMVar' :: MVar a -> (a -> IO (a, b)) -> io b + {-| + Like 'modifyMVar_', but the @IO@ action in the second argument is executed with + asynchronous exceptions masked. + + /Since: 4.6.0.0/ + -} modifyMVarMasked_' :: MVar a -> (a -> IO a) -> io () + {-| + Like 'modifyMVar', but the @IO@ action in the second argument is executed with + asynchronous exceptions masked. + + /Since: 4.6.0.0/ + -} modifyMVarMasked' :: MVar a -> (a -> IO (a, b)) -> io b class (WeakMemAccess io, MVarAccess io) => WeakMVarAccess io where + -- | Make a 'Weak' pointer to an 'MVar', using the second argument as + -- a finalizer to run when 'MVar' is garbage-collected + -- + -- /Since: 4.6.0.0/ mkWeakMVar' :: MVar a -> IO () -> io (Weak (MVar a)) @@ -40,8 +158,10 @@ swapMVar' = swapMVar tryTakeMVar' = tryTakeMVar tryPutMVar' = tryPutMVar + tryReadMVar' = tryReadMVar isEmptyMVar' = isEmptyMVar withMVar' = withMVar + withMVarMasked' = withMVarMasked modifyMVar_' = modifyMVar_ modifyMVar' = modifyMVar modifyMVarMasked_' = modifyMVarMasked_ diff --git a/Access/Control/Concurrent/QSem.hs b/Access/Control/Concurrent/QSem.hs new file mode 100644 --- /dev/null +++ b/Access/Control/Concurrent/QSem.hs @@ -0,0 +1,26 @@ +module Access.Control.Concurrent.QSem + ( module Control.Concurrent.QSem + + , QSemAccess(..) + ) where + + +import Control.Concurrent.QSem + +import Access.Core + + +class Access io => QSemAccess io where + -- |Build a new 'QSem' with a supplied initial quantity. + -- The initial quantity must be at least 0. + newQSem' :: Int -> io QSem + -- |Wait for a unit to become available + waitQSem' :: QSem -> io () + -- |Signal that a unit of the 'QSem' is available + signalQSem' :: QSem -> io () + + +instance QSemAccess IO where + newQSem' = newQSem + waitQSem' = waitQSem + signalQSem' = signalQSem diff --git a/Access/Control/Concurrent/QSemN.hs b/Access/Control/Concurrent/QSemN.hs new file mode 100644 --- /dev/null +++ b/Access/Control/Concurrent/QSemN.hs @@ -0,0 +1,26 @@ +module Access.Control.Concurrent.QSemN + ( module Control.Concurrent.QSemN + + , QSemNAccess(..) + ) where + + +import Control.Concurrent.QSemN + +import Access.Core + + +class Access io => QSemNAccess io where + -- |Build a new 'QSemN' with a supplied initial quantity. + -- The initial quantity must be at least 0. + newQSemN' :: Int -> io QSemN + -- |Wait for the specified quantity to become available + waitQSemN' :: QSemN -> Int -> io () + -- |Signal that a given quantity is now available from the 'QSemN'. + signalQSemN' :: QSemN -> Int -> io () + + +instance QSemNAccess IO where + newQSemN' = newQSemN + waitQSemN' = waitQSemN + signalQSemN' = signalQSemN diff --git a/Access/Control/Exception.hs b/Access/Control/Exception.hs --- a/Access/Control/Exception.hs +++ b/Access/Control/Exception.hs @@ -7,10 +7,10 @@ ) where -import Control.Exception -import Control.Concurrent (ThreadId) +import Control.Concurrent (ThreadId) +import Control.Exception -import Access.Core +import Access.Core class Access io => ExceptionAccess io where throwIO' :: Exception e => e -> io a diff --git a/Access/Core.hs b/Access/Core.hs --- a/Access/Core.hs +++ b/Access/Core.hs @@ -1,15 +1,26 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Access.Core +-- Copyright : (c) Aaron Stevens, 2014 +-- License : GPL2 +-- +-- Maintainer : bheklilr2@gmail.com +-------------------------------------------------------------------------------- + module Access.Core ( Access ) where -import Data.Typeable.Internal (Typeable1) -import Control.Applicative (Applicative) -import Control.Monad.Fix (MonadFix) +import Control.Applicative (Applicative) +import Control.Monad.Fix (MonadFix) +import Data.Typeable (Typeable) +-- | The 'Access' type class. It belongs to several of the same type classes +-- as 'IO'. Notably, it is a 'Monad', a 'Functor', and an 'Applicative'. class ( Monad io , Functor io - , Typeable1 io + , Typeable io , MonadFix io , Applicative io) => Access io where diff --git a/Access/Data/IORef.hs b/Access/Data/IORef.hs --- a/Access/Data/IORef.hs +++ b/Access/Data/IORef.hs @@ -6,10 +6,10 @@ ) where -import Data.IORef +import Data.IORef -import Access.Core -import Access.System.Mem.Weak +import Access.Core +import Access.System.Mem.Weak class Access io => IORefAccess io where diff --git a/Access/Data/Unique.hs b/Access/Data/Unique.hs --- a/Access/Data/Unique.hs +++ b/Access/Data/Unique.hs @@ -5,9 +5,9 @@ ) where -import Data.Unique +import Data.Unique -import Access.Core +import Access.Core class Access io => UniqueAccess io where diff --git a/Access/Debug/Trace.hs b/Access/Debug/Trace.hs --- a/Access/Debug/Trace.hs +++ b/Access/Debug/Trace.hs @@ -5,16 +5,18 @@ ) where -import Debug.Trace +import Debug.Trace -import Access.Core +import Access.Core class Access io => TraceAccess io where traceIO' :: String -> io () traceEventIO' :: String -> io () + traceMarkerIO' :: String -> io () instance TraceAccess IO where - traceIO' = traceIO - traceEventIO' = traceEventIO + traceIO' = traceIO + traceEventIO' = traceEventIO + traceMarkerIO' = traceMarkerIO diff --git a/Access/System/CPUTime.hs b/Access/System/CPUTime.hs --- a/Access/System/CPUTime.hs +++ b/Access/System/CPUTime.hs @@ -5,12 +5,15 @@ ) where -import System.CPUTime +import System.CPUTime -import Access.Core +import Access.Core class Access io => CPUTimeAccess io where + -- |Computation 'getCPUTime' returns the number of picoseconds CPU time + -- used by the current program. The precision of this result is + -- implementation-dependent. getCPUTime' :: io Integer diff --git a/Access/System/Environment.hs b/Access/System/Environment.hs --- a/Access/System/Environment.hs +++ b/Access/System/Environment.hs @@ -5,9 +5,9 @@ ) where -import System.Environment +import System.Environment -import Access.Core +import Access.Core class Access io => EnvironmentAccess io where @@ -16,6 +16,8 @@ getExecutablePath' :: io FilePath getEnv' :: String -> io String lookupEnv' :: String -> io (Maybe String) + setEnv' :: String -> String -> io () + unsetEnv' :: String -> io () withArgs' :: [String] -> IO a -> io a withProgName' :: String -> IO a -> io a getEnvironment' :: io [(String, String)] @@ -27,6 +29,8 @@ getExecutablePath' = getExecutablePath getEnv' = getEnv lookupEnv' = lookupEnv + setEnv' = setEnv + unsetEnv' = unsetEnv withArgs' = withArgs withProgName' = withProgName getEnvironment' = getEnvironment diff --git a/Access/System/Exit.hs b/Access/System/Exit.hs --- a/Access/System/Exit.hs +++ b/Access/System/Exit.hs @@ -5,14 +5,46 @@ ) where -import System.Exit +import System.Exit -import Access.Core +import Access.Core class Access io => ExitAccess io where + -- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. + -- Normally this terminates the program, returning @code@ to the + -- program's caller. + -- + -- On program termination, the standard 'Handle's 'stdout' and + -- 'stderr' are flushed automatically; any other buffered 'Handle's + -- need to be flushed manually, otherwise the buffered data will be + -- discarded. + -- + -- A program that fails in any other way is treated as if it had + -- called 'exitFailure'. + -- A program that terminates successfully without calling 'exitWith' + -- explicitly is treated as it it had called 'exitWith' 'ExitSuccess'. + -- + -- As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses + -- the error handling in the 'IO' monad and cannot be intercepted by + -- 'catch' from the "Prelude". However it is a 'SomeException', and can + -- be caught using the functions of "Control.Exception". This means + -- that cleanup computations added with 'Control.Exception.bracket' + -- (from "Control.Exception") are also executed properly on 'exitWith'. + -- + -- Note: in GHC, 'exitWith' should be called from the main program + -- thread in order to exit the process. When called from another + -- thread, 'exitWith' will throw an 'ExitException' as normal, but the + -- exception will not cause the process itself to exit. + -- exitWith' :: ExitCode -> io a + -- | The computation 'exitFailure' is equivalent to + -- 'exitWith' @(@'ExitFailure' /exitfail/@)@, + -- where /exitfail/ is implementation-dependen exitFailure' :: io a + -- | The computation 'exitSuccess' is equivalent to + -- 'exitWith' 'ExitSuccess', It terminates the program + -- successfully. exitSuccess' :: io a diff --git a/Access/System/IO.hs b/Access/System/IO.hs --- a/Access/System/IO.hs +++ b/Access/System/IO.hs @@ -24,10 +24,10 @@ ) where -import System.IO -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr) +import System.IO -import Access.Core +import Access.Core -- | Provides access to 'Handle' write functions class Access io => HandleWriteAccess io where diff --git a/Access/System/IO/Error.hs b/Access/System/IO/Error.hs --- a/Access/System/IO/Error.hs +++ b/Access/System/IO/Error.hs @@ -5,9 +5,9 @@ ) where -import System.IO.Error +import System.IO.Error -import Access.Core +import Access.Core class Access io => IOErrorAccess io where diff --git a/Access/System/Mem.hs b/Access/System/Mem.hs --- a/Access/System/Mem.hs +++ b/Access/System/Mem.hs @@ -5,14 +5,25 @@ ) where -import System.Mem +import System.Mem -import Access.Core +import Access.Core class Access io => MemAccess io where - performGC' :: io () + -- | Triggers an immediate garbage collection. + performGC' :: io () + -- | Triggers an immediate garbage collection. + -- + -- /Since: 4.7.0.0/ + performMajorGC' :: io () + -- | Triggers an immediate minor garbage collection. + -- + -- /Since: 4.7.0.0/ + performMinorGC' :: io () instance MemAccess IO where performGC' = performGC + performMajorGC' = performMajorGC + performMinorGC' = performMinorGC diff --git a/Access/System/Mem/StableName.hs b/Access/System/Mem/StableName.hs --- a/Access/System/Mem/StableName.hs +++ b/Access/System/Mem/StableName.hs @@ -5,9 +5,9 @@ ) where -import System.Mem.StableName +import System.Mem.StableName -import Access.Core +import Access.Core class Access io => StableNameAccess io where diff --git a/Access/System/Mem/Weak.hs b/Access/System/Mem/Weak.hs --- a/Access/System/Mem/Weak.hs +++ b/Access/System/Mem/Weak.hs @@ -5,9 +5,9 @@ ) where -import System.Mem.Weak +import System.Mem.Weak -import Access.Core +import Access.Core class Access io => WeakMemAccess io where diff --git a/Access/System/Timeout.hs b/Access/System/Timeout.hs --- a/Access/System/Timeout.hs +++ b/Access/System/Timeout.hs @@ -5,9 +5,9 @@ ) where -import System.Timeout +import System.Timeout -import Access.Core +import Access.Core class Access io => TimeoutAccess io where @@ -15,4 +15,32 @@ instance TimeoutAccess IO where + -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result + -- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result + -- is available before the timeout expires, @Just a@ is returned. A negative + -- timeout interval means \"wait indefinitely\". When specifying long timeouts, + -- be careful not to exceed @maxBound :: Int@. + -- + -- The design of this combinator was guided by the objective that @timeout n f@ + -- should behave exactly the same as @f@ as long as @f@ doesn't time out. This + -- means that @f@ has the same 'myThreadId' it would have without the timeout + -- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate + -- further up. It also possible for @f@ to receive exceptions thrown to it by + -- another thread. + -- + -- A tricky implementation detail is the question of how to abort an @IO@ + -- computation. This combinator relies on asynchronous exceptions internally. + -- The technique works very well for computations executing inside of the + -- Haskell runtime system, but it doesn't work at all for non-Haskell code. + -- Foreign function calls, for example, cannot be timed out with this + -- combinator simply because an arbitrary C function cannot receive + -- asynchronous exceptions. When @timeout@ is used to wrap an FFI call that + -- blocks, no timeout event can be delivered until the FFI call returns, which + -- pretty much negates the purpose of the combinator. In practice, however, + -- this limitation is less severe than it may sound. Standard I\/O functions + -- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', Network.Socket.accept, or + -- 'System.IO.hWaitForInput' appear to be blocking, but they really don't + -- because the runtime system uses scheduling mechanisms like @select(2)@ to + -- perform asynchronous I\/O, so it is possible to interrupt standard socket + -- I\/O or file I\/O using this combinator. timeout' = timeout diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,69 +0,0 @@ -base-io-access -============== - -An attempt to break up the monolithic IO monad into small, composable classes -that can be used to restrict a function to only having access to, say, functions -to work with the standard pipes, or a function that can access the environment. -The motivation for this library is to allow people to make a stricter contract -than simply "this function does IO", and express through the type system exactly -what IO is being performed. - -Implementation -============== - -The method used is to make a thinly veiled class breaking up groups of `IO` -actions into smaller sub-groups. As an example: - -```haskell -class Access io => ExitAccess io where - exitWith' :: ExitCode -> io a - exitFailure' :: io a - exitSuccess' :: io a - -instance ExitAccess IO where - exitWith' = exitWith - exitFailure' = exitFailure - exitSuccess' = exitSuccess -``` - -Here the `Access` class is an empty super class that combines `Monad`, -`Applicative`, `Functor`, `Typeable1`, and `MonadFix`. It is the super class -for all the others in this library. Maybe eventually I will make it more -powerful, or add in special support for handling generic `Access` actions, but -for now it's going to remain very simplistic. - -In this example taken from `Access.System.Exit`, we have defined a small class -`ExitAccess` that has three functions, each corresponding to their -implementation in `System.Exit` but with an extra `'` appended to the name. -By itself this class isn't very interesting, but when combined with (the larger -) `StdIOAccess` class, we could write a function like - -```haskell -helpMessage :: (ExitAccess io, StdIOAcess io) => io () -helpMessage = do - putStrLn' "Usage:" - putStrLn' " mytool [options]" - putStrLn' "Options:" - putStrLn' " --help Display this help message" - exitSuccess' - -main :: IO () -main = do - args <- getArgs - if "--help" `elem` args - then helpMessage - else mainLoop -``` - -While this is a simple and contrived example, it illustrates that a function's -capabilities are greatly reduced through this method. Since we often want to -use the most restrictive type we can in Haskell, this provides an easy way to -achieve this when working with the all-encompassing `IO` monad. - -Performance -=========== - -Since the entire library is based on just using typeclasses, there is no runtime -overhead whatsoever. The compiler will optimize away the class lookups, and -every function is simply a thin wrapper around its actual implementation in -`base`. diff --git a/base-io-access.cabal b/base-io-access.cabal --- a/base-io-access.cabal +++ b/base-io-access.cabal @@ -1,5 +1,5 @@ name: base-io-access -version: 0.3.0.1 +version: 0.4.0.0 synopsis: The IO functions included in base delimited into small, composable classes description: An attempt to break up the monolithic IO monad into small, composable classes that can be used to restrict a function to only having access to, say, functions @@ -15,7 +15,6 @@ category: System build-type: Simple cabal-version: >=1.10 -extra-source-files: README.md source-repository head type: git @@ -25,6 +24,8 @@ exposed-modules: Access.Control.Concurrent, Access.Control.Concurrent.Chan, Access.Control.Concurrent.MVar, + Access.Control.Concurrent.QSem, + Access.Control.Concurrent.QSemN, Access.Control.Exception, Access.Data.IORef, @@ -44,5 +45,5 @@ Access.Core - build-depends: base >=4.6 && <4.7 + build-depends: base >=4.7 && <4.8 default-language: Haskell2010