--- /dev/null
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- A common interface to a collection of useful concurrency
+-- abstractions.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent (
+ -- * Concurrent Haskell
+
+ -- $conc_intro
+
+ -- * Basic concurrency operations
+
+ ThreadId,
+#ifdef __GLASGOW_HASKELL__
+ myThreadId,
+#endif
+
+ forkIO,
+#ifdef __GLASGOW_HASKELL__
+ killThread,
+ throwTo,
+#endif
+
+ -- * Scheduling
+
+ -- $conc_scheduling
+ yield, -- :: IO ()
+
+ -- ** Blocking
+
+ -- $blocking
+
+#ifdef __GLASGOW_HASKELL__
+ -- ** Waiting
+ threadDelay, -- :: Int -> IO ()
+ threadWaitRead, -- :: Int -> IO ()
+ threadWaitWrite, -- :: Int -> IO ()
+#endif
+
+ -- * Communication abstractions
+
+ module Control.Concurrent.MVar,
+ module Control.Concurrent.Chan,
+ module Control.Concurrent.QSem,
+ module Control.Concurrent.QSemN,
+ module Control.Concurrent.SampleVar,
+
+ -- * Merging of streams
+#ifndef __HUGS__
+ mergeIO, -- :: [a] -> [a] -> IO [a]
+ nmergeIO, -- :: [[a]] -> IO [a]
+#endif
+ -- $merge
+
+#ifdef __GLASGOW_HASKELL__
+ -- * Bound Threads
+ -- $boundthreads
+ rtsSupportsBoundThreads,
+ forkOS,
+ isCurrentThreadBound,
+ runInBoundThread,
+ runInUnboundThread
+#endif
+
+ -- * GHC's implementation of concurrency
+
+ -- |This section describes features specific to GHC's
+ -- implementation of Concurrent Haskell.
+
+ -- ** Haskell threads and Operating System threads
+
+ -- $osthreads
+
+ -- ** Terminating the program
+
+ -- $termination
+
+ -- ** Pre-emption
+
+ -- $preemption
+ ) where
+
+import Prelude
+
+import Control.Exception.Base as Exception
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exception
+import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield,
+ threadDelay, forkIO, childHandler )
+import qualified GHC.Conc
+import GHC.IOBase ( IO(..) )
+import GHC.IOBase ( unsafeInterleaveIO )
+import GHC.IOBase ( newIORef, readIORef, writeIORef )
+import GHC.Base
+
+import System.Posix.Types ( Fd )
+import Foreign.StablePtr
+import Foreign.C.Types ( CInt )
+import Control.Monad ( when )
+
+#ifdef mingw32_HOST_OS
+import Foreign.C
+import System.IO
+import GHC.Handle
+#endif
+#endif
+
+#ifdef __HUGS__
+import Hugs.ConcBase
+#endif
+
+import Control.Concurrent.MVar
+import Control.Concurrent.Chan
+import Control.Concurrent.QSem
+import Control.Concurrent.QSemN
+import Control.Concurrent.SampleVar
+
+#ifdef __HUGS__
+type ThreadId = ()
+#endif
+
+{- $conc_intro
+
+The concurrency extension for Haskell is described in the paper
+/Concurrent Haskell/
+<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.
+
+Concurrency is \"lightweight\", which means that both thread creation
+and context switching overheads are extremely low. Scheduling of
+Haskell threads is done internally in the Haskell runtime system, and
+doesn't make use of any operating system-supplied thread packages.
+
+However, if you want to interact with a foreign library that expects your
+program to use the operating system-supplied thread package, you can do so
+by using 'forkOS' instead of 'forkIO'.
+
+Haskell threads can communicate via 'MVar's, a kind of synchronised
+mutable variable (see "Control.Concurrent.MVar"). Several common
+concurrency abstractions can be built from 'MVar's, and these are
+provided by the "Control.Concurrent" library.
+In GHC, threads may also communicate via exceptions.
+-}
+
+{- $conc_scheduling
+
+ Scheduling may be either pre-emptive or co-operative,
+ depending on the implementation of Concurrent Haskell (see below
+ for information related to specific compilers). In a co-operative
+ system, context switches only occur when you use one of the
+ primitives defined in this module. This means that programs such
+ as:
+
+
+> main = forkIO (write 'a') >> write 'b'
+> where write c = putChar c >> write c
+
+ will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,
+ instead of some random interleaving of @a@s and @b@s. In
+ practice, cooperative multitasking is sufficient for writing
+ simple graphical user interfaces.
+-}
+
+{- $blocking
+Different Haskell implementations have different characteristics with
+regard to which operations block /all/ threads.
+
+Using GHC without the @-threaded@ option, all foreign calls will block
+all other Haskell threads in the system, although I\/O operations will
+not. With the @-threaded@ option, only foreign calls with the @unsafe@
+attribute will block all other threads.
+
+Using Hugs, all I\/O operations and foreign calls will block all other
+Haskell threads.
+-}
+
+#ifndef __HUGS__
+max_buff_size :: Int
+max_buff_size = 1
+
+mergeIO :: [a] -> [a] -> IO [a]
+nmergeIO :: [[a]] -> IO [a]
+
+-- $merge
+-- The 'mergeIO' and 'nmergeIO' functions fork one thread for each
+-- input list that concurrently evaluates that list; the results are
+-- merged into a single output list.
+--
+-- Note: Hugs does not provide these functions, since they require
+-- preemptive multitasking.
+
+mergeIO ls rs
+ = newEmptyMVar >>= \ tail_node ->
+ newMVar tail_node >>= \ tail_list ->
+ newQSem max_buff_size >>= \ e ->
+ newMVar 2 >>= \ branches_running ->
+ let
+ buff = (tail_list,e)
+ in
+ forkIO (suckIO branches_running buff ls) >>
+ forkIO (suckIO branches_running buff rs) >>
+ takeMVar tail_node >>= \ val ->
+ signalQSem e >>
+ return val
+
+type Buffer a
+ = (MVar (MVar [a]), QSem)
+
+suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
+
+suckIO branches_running buff@(tail_list,e) vs
+ = case vs of
+ [] -> takeMVar branches_running >>= \ val ->
+ if val == 1 then
+ takeMVar tail_list >>= \ node ->
+ putMVar node [] >>
+ putMVar tail_list node
+ else
+ putMVar branches_running (val-1)
+ (x:xs) ->
+ waitQSem e >>
+ takeMVar tail_list >>= \ node ->
+ newEmptyMVar >>= \ next_node ->
+ unsafeInterleaveIO (
+ takeMVar next_node >>= \ y ->
+ signalQSem e >>
+ return y) >>= \ next_node_val ->
+ putMVar node (x:next_node_val) >>
+ putMVar tail_list next_node >>
+ suckIO branches_running buff xs
+
+nmergeIO lss
+ = let
+ len = length lss
+ in
+ newEmptyMVar >>= \ tail_node ->
+ newMVar tail_node >>= \ tail_list ->
+ newQSem max_buff_size >>= \ e ->
+ newMVar len >>= \ branches_running ->
+ let
+ buff = (tail_list,e)
+ in
+ mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
+ takeMVar tail_node >>= \ val ->
+ signalQSem e >>
+ return val
+ where
+ mapIO f xs = sequence (map f xs)
+#endif /* __HUGS__ */
+
+#ifdef __GLASGOW_HASKELL__
+-- ---------------------------------------------------------------------------
+-- Bound Threads
+
+{- $boundthreads
+ #boundthreads#
+
+Support for multiple operating system threads and bound threads as described
+below is currently only available in the GHC runtime system if you use the
+/-threaded/ option when linking.
+
+Other Haskell systems do not currently support multiple operating system threads.
+
+A bound thread is a haskell thread that is /bound/ to an operating system
+thread. While the bound thread is still scheduled by the Haskell run-time
+system, the operating system thread takes care of all the foreign calls made
+by the bound thread.
+
+To a foreign library, the bound thread will look exactly like an ordinary
+operating system thread created using OS functions like @pthread_create@
+or @CreateThread@.
+
+Bound threads can be created using the 'forkOS' function below. All foreign
+exported functions are run in a bound thread (bound to the OS thread that
+called the function). Also, the @main@ action of every Haskell program is
+run in a bound thread.
+
+Why do we need this? Because if a foreign library is called from a thread
+created using 'forkIO', it won't have access to any /thread-local state/ -
+state variables that have specific values for each OS thread
+(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some
+libraries (OpenGL, for example) will not work from a thread created using
+'forkIO'. They work fine in threads created using 'forkOS' or when called
+from @main@ or from a @foreign export@.
+
+In terms of performance, 'forkOS' (aka bound) threads are much more
+expensive than 'forkIO' (aka unbound) threads, because a 'forkOS'
+thread is tied to a particular OS thread, whereas a 'forkIO' thread
+can be run by any OS thread. Context-switching between a 'forkOS'
+thread and a 'forkIO' thread is many times more expensive than between
+two 'forkIO' threads.
+
+Note in particular that the main program thread (the thread running
+@Main.main@) is always a bound thread, so for good concurrency
+performance you should ensure that the main thread is not doing
+repeated communication with other threads in the system. Typically
+this means forking subthreads to do the work using 'forkIO', and
+waiting for the results in the main thread.
+
+-}
+
+-- | 'True' if bound threads are supported.
+-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
+-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
+-- fail.
+foreign import ccall rtsSupportsBoundThreads :: Bool
+
+
+{- |
+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
+
+foreign export ccall forkOS_entry
+ :: StablePtr (IO ()) -> IO ()
+
+foreign import ccall "forkOS_entry" forkOS_entry_reimported
+ :: StablePtr (IO ()) -> IO ()
+
+forkOS_entry :: StablePtr (IO ()) -> IO ()
+forkOS_entry stableAction = do
+ action <- deRefStablePtr stableAction
+ action
+
+foreign import ccall forkOS_createThread
+ :: StablePtr (IO ()) -> IO CInt
+
+failNonThreaded :: IO a
+failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
+ ++"(use ghc -threaded when linking)"
+
+forkOS action0
+ | rtsSupportsBoundThreads = do
+ mv <- newEmptyMVar
+ b <- Exception.blocked
+ let
+ -- async exceptions are blocked in the child if they are blocked
+ -- in the parent, as for forkIO (see #1048). forkOS_createThread
+ -- creates a thread with exceptions blocked by default.
+ action1 | b = action0
+ | otherwise = unblock action0
+
+ action_plus = Exception.catch action1 childHandler
+
+ entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
+ err <- forkOS_createThread entry
+ when (err /= 0) $ fail "Cannot create OS thread."
+ tid <- takeMVar mv
+ freeStablePtr entry
+ return tid
+ | otherwise = failNonThreaded
+
+-- | 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
+isCurrentThreadBound = IO $ \ s# ->
+ case isCurrentThreadBound# s# of
+ (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
+
+
+{- |
+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
+
+runInBoundThread action
+ | rtsSupportsBoundThreads = do
+ bound <- isCurrentThreadBound
+ if bound
+ then action
+ else do
+ ref <- newIORef undefined
+ let action_plus = Exception.try action >>= writeIORef ref
+ resultOrException <-
+ bracket (newStablePtr action_plus)
+ freeStablePtr
+ (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref)
+ case resultOrException of
+ Left exception -> Exception.throw (exception :: SomeException)
+ Right result -> return result
+ | otherwise = failNonThreaded
+
+{- |
+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@.
+-}
+runInUnboundThread :: IO a -> IO a
+
+runInUnboundThread action = do
+ bound <- isCurrentThreadBound
+ if bound
+ then do
+ mv <- newEmptyMVar
+ forkIO (Exception.try action >>= putMVar mv)
+ takeMVar mv >>= \ei -> case ei of
+ Left exception -> Exception.throw (exception :: SomeException)
+ Right result -> return result
+ else action
+
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifdef __GLASGOW_HASKELL__
+-- ---------------------------------------------------------------------------
+-- threadWaitRead/threadWaitWrite
+
+-- | Block the current thread until data is available to read on the
+-- given file descriptor (GHC only).
+threadWaitRead :: Fd -> IO ()
+threadWaitRead fd
+#ifdef mingw32_HOST_OS
+ -- we have no IO manager implementing threadWaitRead on Windows.
+ -- fdReady does the right thing, but we have to call it in a
+ -- separate thread, otherwise threadWaitRead won't be interruptible,
+ -- and this only works with -threaded.
+ | threaded = withThread (waitFd fd 0)
+ | otherwise = case fd of
+ 0 -> do hWaitForInput stdin (-1); return ()
+ -- hWaitForInput does work properly, but we can only
+ -- do this for stdin since we know its FD.
+ _ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput"
+#else
+ = GHC.Conc.threadWaitRead fd
+#endif
+
+-- | Block the current thread until data can be written to the
+-- given file descriptor (GHC only).
+threadWaitWrite :: Fd -> IO ()
+threadWaitWrite fd
+#ifdef mingw32_HOST_OS
+ | threaded = withThread (waitFd fd 1)
+ | otherwise = error "threadWaitWrite requires -threaded on Windows"
+#else
+ = GHC.Conc.threadWaitWrite fd
+#endif
+
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
+
+withThread :: IO a -> IO a
+withThread io = do
+ m <- newEmptyMVar
+ forkIO $ try io >>= putMVar m
+ x <- takeMVar m
+ case x of
+ Right a -> return a
+ Left e -> throwIO (e :: IOException)
+
+waitFd :: Fd -> CInt -> IO ()
+waitFd fd write = do
+ throwErrnoIfMinus1 "fdReady" $
+ fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0
+ return ()
+
+iNFINITE :: CInt
+iNFINITE = 0xFFFFFFFF -- urgh
+
+foreign import ccall safe "fdReady"
+ fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+#endif
+
+-- ---------------------------------------------------------------------------
+-- More docs
+
+{- $osthreads
+
+ #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and
+ are managed entirely by the GHC runtime. Typically Haskell
+ threads are an order of magnitude or two more efficient (in
+ terms of both time and space) than operating system threads.
+
+ The downside of having lightweight threads is that only one can
+ run at a time, so if one thread blocks in a foreign call, for
+ example, the other threads cannot continue. The GHC runtime
+ works around this by making use of full OS threads where
+ necessary. When the program is built with the @-threaded@
+ option (to link against the multithreaded version of the
+ runtime), a thread making a @safe@ foreign call will not block
+ the other threads in the system; another OS thread will take
+ over running Haskell threads until the original call returns.
+ The runtime maintains a pool of these /worker/ threads so that
+ multiple Haskell threads can be involved in external calls
+ simultaneously.
+
+ The "System.IO" library manages multiplexing in its own way. On
+ Windows systems it uses @safe@ foreign calls to ensure that
+ threads doing I\/O operations don't block the whole runtime,
+ whereas on Unix systems all the currently blocked I\/O reqwests
+ are managed by a single thread (the /IO manager thread/) using
+ @select@.
+
+ The runtime will run a Haskell thread using any of the available
+ worker OS threads. If you need control over which particular OS
+ thread is used to run a given Haskell thread, perhaps because
+ you need to call a foreign library that uses OS-thread-local
+ state, then you need bound threads (see "Control.Concurrent#boundthreads").
+
+ If you don't use the @-threaded@ option, then the runtime does
+ not make use of multiple OS threads. Foreign calls will block
+ all other running Haskell threads until the call returns. The
+ "System.IO" library still does multiplexing, so there can be multiple
+ threads doing I\/O, and this is handled internally by the runtime using
+ @select@.
+-}
+
+{- $termination
+
+ In a standalone GHC program, only the main thread is
+ required to terminate in order for the process to terminate.
+ Thus all other forked threads will simply terminate at the same
+ time as the main thread (the terminology for this kind of
+ behaviour is \"daemonic threads\").
+
+ If you want the program to wait for child threads to
+ finish before exiting, you need to program this yourself. A
+ simple mechanism is to have each child thread write to an
+ 'MVar' when it completes, and have the main
+ thread wait on all the 'MVar's before
+ exiting:
+
+> myForkIO :: IO () -> IO (MVar ())
+> myForkIO io = do
+> mvar <- newEmptyMVar
+> forkIO (io `finally` putMVar mvar ())
+> return mvar
+
+ Note that we use 'finally' from the
+ "Control.Exception" module to make sure that the
+ 'MVar' is written to even if the thread dies or
+ is killed for some reason.
+
+ A better method is to keep a global list of all child
+ threads which we should wait for at the end of the program:
+
+> children :: MVar [MVar ()]
+> children = unsafePerformIO (newMVar [])
+>
+> waitForChildren :: IO ()
+> waitForChildren = do
+> cs <- takeMVar children
+> case cs of
+> [] -> return ()
+> m:ms -> do
+> putMVar children ms
+> takeMVar m
+> waitForChildren
+>
+> forkChild :: IO () -> IO ThreadId
+> forkChild io = do
+> mvar <- newEmptyMVar
+> childs <- takeMVar children
+> putMVar children (mvar:childs)
+> forkIO (io `finally` putMVar mvar ())
+>
+> main =
+> later waitForChildren $
+> ...
+
+ The main thread principle also applies to calls to Haskell from
+ outside, using @foreign export@. When the @foreign export@ed
+ function is invoked, it starts a new main thread, and it returns
+ when this main thread terminates. If the call causes new
+ threads to be forked, they may remain in the system after the
+ @foreign export@ed function has returned.
+-}
+
+{- $preemption
+
+ GHC implements pre-emptive multitasking: the execution of
+ threads are interleaved in a random fashion. More specifically,
+ a thread may be pre-empted whenever it allocates some memory,
+ which unfortunately means that tight loops which do no
+ allocation tend to lock out other threads (this only seems to
+ happen with pathological benchmark-style code, however).
+
+ The rescheduling timer runs on a 20ms granularity by
+ default, but this may be altered using the
+ @-i\<n\>@ RTS option. After a rescheduling
+ \"tick\" the running thread is pre-empted as soon as
+ possible.
+
+ One final note: the
+ @aaaa@ @bbbb@ example may not
+ work too well on GHC (see Scheduling, above), due
+ to the locking on a 'System.IO.Handle'. Only one thread
+ may hold the lock on a 'System.IO.Handle' at any one
+ time, so if a reschedule happens while a thread is holding the
+ lock, the other thread won't be able to run. The upshot is that
+ the switch from @aaaa@ to
+ @bbbbb@ happens infrequently. It can be
+ improved by lowering the reschedule tick period. We also have a
+ patch that causes a reschedule whenever a thread waiting on a
+ lock is woken up, but haven't found it to be useful for anything
+ other than this example :-)
+-}
+#endif /* __GLASGOW_HASKELL__ */
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.Chan
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Unbounded channels.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.Chan
+ (
+ -- * The 'Chan' type
+ Chan, -- abstract
+
+ -- * Operations
+ newChan, -- :: IO (Chan a)
+ writeChan, -- :: Chan a -> a -> IO ()
+ readChan, -- :: Chan a -> IO a
+ dupChan, -- :: Chan a -> IO (Chan a)
+ unGetChan, -- :: Chan a -> a -> IO ()
+ isEmptyChan, -- :: Chan a -> IO Bool
+
+ -- * Stream interface
+ getChanContents, -- :: Chan a -> IO [a]
+ writeList2Chan, -- :: Chan a -> [a] -> IO ()
+ ) where
+
+import Prelude
+
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import Control.Concurrent.MVar
+import Data.Typeable
+
+#include "Typeable.h"
+
+-- A channel is represented by two @MVar@s keeping track of the two ends
+-- of the channel contents,i.e., the read- and write ends. Empty @MVar@s
+-- are used to handle consumers trying to read from an empty channel.
+
+-- |'Chan' is an abstract type representing an unbounded FIFO channel.
+data Chan a
+ = Chan (MVar (Stream a))
+ (MVar (Stream a))
+
+INSTANCE_TYPEABLE1(Chan,chanTc,"Chan")
+
+type Stream a = MVar (ChItem a)
+
+data ChItem a = ChItem a (Stream a)
+
+-- See the Concurrent Haskell paper for a diagram explaining the
+-- how the different channel operations proceed.
+
+-- @newChan@ sets up the read and write end of a channel by initialising
+-- these two @MVar@s with an empty @MVar@.
+
+-- |Build and returns a new instance of 'Chan'.
+newChan :: IO (Chan a)
+newChan = do
+ hole <- newEmptyMVar
+ readVar <- newMVar hole
+ writeVar <- newMVar hole
+ return (Chan readVar writeVar)
+
+-- To put an element on a channel, a new hole at the write end is created.
+-- What was previously the empty @MVar@ at the back of the channel is then
+-- filled in with a new stream element holding the entered value and the
+-- new hole.
+
+-- |Write a value to a 'Chan'.
+writeChan :: Chan a -> a -> IO ()
+writeChan (Chan _ writeVar) val = do
+ new_hole <- newEmptyMVar
+ modifyMVar_ writeVar $ \old_hole -> do
+ putMVar old_hole (ChItem val new_hole)
+ return new_hole
+
+-- |Read the next value from the 'Chan'.
+readChan :: Chan a -> IO a
+readChan (Chan readVar _) = do
+ modifyMVar readVar $ \read_end -> do
+ (ChItem val new_read_end) <- readMVar read_end
+ -- Use readMVar here, not takeMVar,
+ -- else dupChan doesn't work
+ return (new_read_end, val)
+
+-- |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.
+dupChan :: Chan a -> IO (Chan a)
+dupChan (Chan _ writeVar) = do
+ hole <- readMVar writeVar
+ newReadVar <- newMVar hole
+ return (Chan newReadVar writeVar)
+
+-- |Put a data item back onto a channel, where it will be the next item read.
+unGetChan :: Chan a -> a -> IO ()
+unGetChan (Chan readVar _) val = do
+ new_read_end <- newEmptyMVar
+ modifyMVar_ readVar $ \read_end -> do
+ putMVar new_read_end (ChItem val read_end)
+ return new_read_end
+
+-- |Returns 'True' if the supplied 'Chan' is empty.
+isEmptyChan :: Chan a -> IO Bool
+isEmptyChan (Chan readVar writeVar) = do
+ withMVar readVar $ \r -> do
+ w <- readMVar writeVar
+ let eq = r == w
+ eq `seq` return eq
+
+-- Operators for interfacing with functional streams.
+
+-- |Return a lazy list representing the contents of the supplied
+-- 'Chan', much like 'System.IO.hGetContents'.
+getChanContents :: Chan a -> IO [a]
+getChanContents ch
+ = unsafeInterleaveIO (do
+ x <- readChan ch
+ xs <- getChanContents ch
+ return (x:xs)
+ )
+
+-- |Write an entire list of items to a 'Chan'.
+writeList2Chan :: Chan a -> [a] -> IO ()
+writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.MVar
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Synchronising variables
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.MVar
+ (
+ -- * @MVar@s
+ MVar -- abstract
+ , newEmptyMVar -- :: IO (MVar a)
+ , newMVar -- :: a -> IO (MVar a)
+ , takeMVar -- :: MVar a -> IO a
+ , putMVar -- :: MVar a -> a -> IO ()
+ , readMVar -- :: MVar a -> IO a
+ , swapMVar -- :: MVar a -> a -> IO a
+ , tryTakeMVar -- :: MVar a -> IO (Maybe a)
+ , tryPutMVar -- :: MVar a -> a -> IO Bool
+ , isEmptyMVar -- :: MVar a -> IO Bool
+ , withMVar -- :: MVar a -> (a -> IO b) -> IO b
+ , modifyMVar_ -- :: MVar a -> (a -> IO a) -> IO ()
+ , modifyMVar -- :: MVar a -> (a -> IO (a,b)) -> IO b
+#ifndef __HUGS__
+ , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+#endif
+ ) where
+
+#ifdef __HUGS__
+import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+ tryTakeMVar, tryPutMVar, isEmptyMVar,
+ )
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+ tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
+ )
+#endif
+
+import Prelude
+import Control.Exception.Base
+
+{-|
+ This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
+ from the 'MVar', puts it back, and also returns it.
+-}
+readMVar :: MVar a -> IO a
+readMVar m =
+ block $ do
+ a <- takeMVar m
+ putMVar m a
+ return a
+
+{-|
+ Take a value from an 'MVar', put a new value into the 'MVar' and
+ return the value taken. Note that there is a race condition whereby
+ another process can put something in the 'MVar' after the take
+ happens but before the put does.
+-}
+swapMVar :: MVar a -> a -> IO a
+swapMVar mvar new =
+ block $ do
+ old <- takeMVar mvar
+ putMVar mvar new
+ return old
+
+{-|
+ 'withMVar' is a 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").
+-}
+{-# INLINE withMVar #-}
+-- inlining has been reported to have dramatic effects; see
+-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
+withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar m io =
+ block $ do
+ a <- takeMVar m
+ b <- unblock (io a) `onException` putMVar m a
+ putMVar m a
+ return b
+
+{-|
+ A 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.
+-}
+{-# INLINE modifyMVar_ #-}
+modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
+modifyMVar_ m io =
+ block $ do
+ a <- takeMVar m
+ a' <- unblock (io a) `onException` putMVar m a
+ putMVar m a'
+
+{-|
+ A slight variation on 'modifyMVar_' that allows a value to be
+ returned (@b@) in addition to the modified value of the 'MVar'.
+-}
+{-# INLINE modifyMVar #-}
+modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
+modifyMVar m io =
+ block $ do
+ a <- takeMVar m
+ (a',b) <- unblock (io a) `onException` putMVar m a
+ putMVar m a'
+ return b
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.QSem
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Simple quantity semaphores.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSem
+ ( -- * Simple Quantity Semaphores
+ QSem, -- abstract
+ newQSem, -- :: Int -> IO QSem
+ waitQSem, -- :: QSem -> IO ()
+ signalQSem -- :: QSem -> IO ()
+ ) where
+
+import Prelude
+import Control.Concurrent.MVar
+import Data.Typeable
+
+#include "Typeable.h"
+
+-- General semaphores are also implemented readily in terms of shared
+-- @MVar@s, only have to catch the case when the semaphore is tried
+-- waited on when it is empty (==0). Implement this in the same way as
+-- shared variables are implemented - maintaining a list of @MVar@s
+-- representing threads currently waiting. The counter is a shared
+-- variable, ensuring the mutual exclusion on its access.
+
+-- |A 'QSem' is a simple quantity semaphore, in which the available
+-- \"quantity\" is always dealt with in units of one.
+newtype QSem = QSem (MVar (Int, [MVar ()]))
+
+INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
+
+-- |Build a new 'QSem'
+newQSem :: Int -> IO QSem
+newQSem initial = do
+ sem <- newMVar (initial, [])
+ return (QSem sem)
+
+-- |Wait for a unit to become available
+waitQSem :: QSem -> IO ()
+waitQSem (QSem sem) = do
+ (avail,blocked) <- takeMVar sem -- gain ex. access
+ if avail > 0 then
+ putMVar sem (avail-1,[])
+ else do
+ block <- newEmptyMVar
+ {-
+ Stuff the reader at the back of the queue,
+ so as to preserve waiting order. A signalling
+ process then only have to pick the MVar at the
+ front of the blocked list.
+
+ The version of waitQSem given in the paper could
+ lead to starvation.
+ -}
+ putMVar sem (0, blocked++[block])
+ takeMVar block
+
+-- |Signal that a unit of the 'QSem' is available
+signalQSem :: QSem -> IO ()
+signalQSem (QSem sem) = do
+ (avail,blocked) <- takeMVar sem
+ case blocked of
+ [] -> putMVar sem (avail+1,[])
+
+ (block:blocked') -> do
+ putMVar sem (0,blocked')
+ putMVar block ()
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.QSemN
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Quantity semaphores in which each thread may wait for an arbitrary
+-- \"amount\".
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSemN
+ ( -- * General Quantity Semaphores
+ QSemN, -- abstract
+ newQSemN, -- :: Int -> IO QSemN
+ waitQSemN, -- :: QSemN -> Int -> IO ()
+ signalQSemN -- :: QSemN -> Int -> IO ()
+ ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+import Data.Typeable
+
+#include "Typeable.h"
+
+-- |A 'QSemN' is a quantity semaphore, in which the available
+-- \"quantity\" may be signalled or waited for in arbitrary amounts.
+newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
+
+INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")
+
+-- |Build a new 'QSemN' with a supplied initial quantity.
+newQSemN :: Int -> IO QSemN
+newQSemN initial = do
+ sem <- newMVar (initial, [])
+ return (QSemN sem)
+
+-- |Wait for the specified quantity to become available
+waitQSemN :: QSemN -> Int -> IO ()
+waitQSemN (QSemN sem) sz = do
+ (avail,blocked) <- takeMVar sem -- gain ex. access
+ if (avail - sz) >= 0 then
+ -- discharging 'sz' still leaves the semaphore
+ -- in an 'unblocked' state.
+ putMVar sem (avail-sz,blocked)
+ else do
+ block <- newEmptyMVar
+ putMVar sem (avail, blocked++[(sz,block)])
+ takeMVar block
+
+-- |Signal that a given quantity is now available from the 'QSemN'.
+signalQSemN :: QSemN -> Int -> IO ()
+signalQSemN (QSemN sem) n = do
+ (avail,blocked) <- takeMVar sem
+ (avail',blocked') <- free (avail+n) blocked
+ putMVar sem (avail',blocked')
+ where
+ free avail [] = return (avail,[])
+ free avail ((req,block):blocked)
+ | avail >= req = do
+ putMVar block ()
+ free (avail-req) blocked
+ | otherwise = do
+ (avail',blocked') <- free avail blocked
+ return (avail',(req,block):blocked')
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.SampleVar
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Sample variables
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.SampleVar
+ (
+ -- * Sample Variables
+ SampleVar, -- :: type _ =
+
+ newEmptySampleVar, -- :: IO (SampleVar a)
+ newSampleVar, -- :: a -> IO (SampleVar a)
+ emptySampleVar, -- :: SampleVar a -> IO ()
+ readSampleVar, -- :: SampleVar a -> IO a
+ writeSampleVar, -- :: SampleVar a -> a -> IO ()
+ isEmptySampleVar, -- :: SampleVar a -> IO Bool
+
+ ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+
+-- |
+-- Sample variables are slightly different from a normal 'MVar':
+--
+-- * Reading an empty 'SampleVar' causes the reader to block.
+-- (same as 'takeMVar' on empty 'MVar')
+--
+-- * Reading a filled 'SampleVar' empties it and returns value.
+-- (same as 'takeMVar')
+--
+-- * Writing to an empty 'SampleVar' fills it with a value, and
+-- potentially, wakes up a blocked reader (same as for 'putMVar' on
+-- empty 'MVar').
+--
+-- * Writing to a filled 'SampleVar' overwrites the current value.
+-- (different from 'putMVar' on full 'MVar'.)
+
+type SampleVar a
+ = MVar (Int, -- 1 == full
+ -- 0 == empty
+ -- <0 no of readers blocked
+ MVar a)
+
+-- |Build a new, empty, 'SampleVar'
+newEmptySampleVar :: IO (SampleVar a)
+newEmptySampleVar = do
+ v <- newEmptyMVar
+ newMVar (0,v)
+
+-- |Build a 'SampleVar' with an initial value.
+newSampleVar :: a -> IO (SampleVar a)
+newSampleVar a = do
+ v <- newEmptyMVar
+ putMVar v a
+ newMVar (1,v)
+
+-- |If the SampleVar is full, leave it empty. Otherwise, do nothing.
+emptySampleVar :: SampleVar a -> IO ()
+emptySampleVar v = do
+ (readers, var) <- takeMVar v
+ if readers > 0 then do
+ takeMVar var
+ putMVar v (0,var)
+ else
+ putMVar v (readers,var)
+
+-- |Wait for a value to become available, then take it and return.
+readSampleVar :: SampleVar a -> IO a
+readSampleVar svar = do
+--
+-- filled => make empty and grab sample
+-- not filled => try to grab value, empty when read val.
+--
+ (readers,val) <- takeMVar svar
+ putMVar svar (readers-1,val)
+ takeMVar val
+
+-- |Write a value into the 'SampleVar', overwriting any previous value that
+-- was there.
+writeSampleVar :: SampleVar a -> a -> IO ()
+writeSampleVar svar v = do
+--
+-- filled => overwrite
+-- not filled => fill, write val
+--
+ (readers,val) <- takeMVar svar
+ case readers of
+ 1 ->
+ swapMVar val v >>
+ putMVar svar (1,val)
+ _ ->
+ putMVar val v >>
+ putMVar svar (min 1 (readers+1), val)
+
+-- | Returns 'True' if the 'SampleVar' is currently empty.
+--
+-- Note that this function is only useful if you know that no other
+-- threads can be modifying the state of the 'SampleVar', because
+-- otherwise the state of the 'SampleVar' may have changed by the time
+-- you see the result of 'isEmptySampleVar'.
+--
+isEmptySampleVar :: SampleVar a -> IO Bool
+isEmptySampleVar svar = do
+ (readers, _) <- readMVar svar
+ return (readers == 0)
+
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Unique
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- An abstract interface to a unique symbol generator.
+--
+-----------------------------------------------------------------------------
+
+module Data.Unique (
+ -- * Unique objects
+ Unique, -- instance (Eq, Ord)
+ newUnique, -- :: IO Unique
+ hashUnique -- :: Unique -> Int
+ ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+import System.IO.Unsafe (unsafePerformIO)
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Num
+#endif
+
+-- | An abstract unique object. Objects of type 'Unique' may be
+-- compared for equality and ordering and hashed into 'Int'.
+newtype Unique = Unique Integer deriving (Eq,Ord)
+
+uniqSource :: MVar Integer
+uniqSource = unsafePerformIO (newMVar 0)
+{-# NOINLINE uniqSource #-}
+
+-- | Creates a new object of type 'Unique'. The value returned will
+-- not compare equal to any other value of type 'Unique' returned by
+-- previous calls to 'newUnique'. There is no limit on the number of
+-- times 'newUnique' may be called.
+newUnique :: IO Unique
+newUnique = do
+ val <- takeMVar uniqSource
+ let next = val+1
+ putMVar uniqSource next
+ return (Unique next)
+
+-- | Hashes a 'Unique' into an 'Int'. Two 'Unique's may hash to the
+-- same value, although in practice this is unlikely. The 'Int'
+-- returned makes a good hash key.
+hashUnique :: Unique -> Int
+#if defined(__GLASGOW_HASKELL__)
+hashUnique (Unique i) = I# (hashInteger i)
+#else
+hashUnique (Unique u) = fromInteger (u `mod` (toInteger (maxBound :: Int) + 1))
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Console.GetOpt
+-- Copyright : (c) Sven Panne 2002-2005
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- This library provides facilities for parsing the command-line options
+-- in a standalone program. It is essentially a Haskell port of the GNU
+-- @getopt@ library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation:
+
+* To enforce a coherent description of options and arguments, there
+ are explanation fields in the option/argument descriptor.
+
+* Error messages are now more informative, but no longer POSIX
+ compliant... :-(
+
+And a final Haskell advertisement: The GNU C implementation uses well
+over 1100 lines, we need only 195 here, including a 46 line example!
+:-)
+-}
+
+module System.Console.GetOpt (
+ -- * GetOpt
+ getOpt, getOpt',
+ usageInfo,
+ ArgOrder(..),
+ OptDescr(..),
+ ArgDescr(..),
+
+ -- * Examples
+
+ -- |To hopefully illuminate the role of the different data structures,
+ -- here are the command-line options for a (very simple) compiler,
+ -- done in two different ways.
+ -- The difference arises because the type of 'getOpt' is
+ -- parameterized by the type of values derived from flags.
+
+ -- ** Interpreting flags as concrete values
+ -- $example1
+
+ -- ** Interpreting flags as transformations of an options record
+ -- $example2
+) where
+
+import Prelude -- necessary to get dependencies right
+
+import Data.List ( isPrefixOf, find )
+
+-- |What to do with options following non-options
+data ArgOrder a
+ = RequireOrder -- ^ no option processing after first non-option
+ | Permute -- ^ freely intersperse options and non-options
+ | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+{-|
+Each 'OptDescr' describes a single option.
+
+The arguments to 'Option' are:
+
+* list of short option characters
+
+* list of long option strings (without \"--\")
+
+* argument descriptor
+
+* explanation of option for user
+-}
+data OptDescr a = -- description of a single options:
+ Option [Char] -- list of short option characters
+ [String] -- list of long option strings (without "--")
+ (ArgDescr a) -- argument descriptor
+ String -- explanation of option for user
+
+-- |Describes whether an option takes an argument or not, and if so
+-- how the argument is injected into a value of type @a@.
+data ArgDescr a
+ = NoArg a -- ^ no argument expected
+ | ReqArg (String -> a) String -- ^ option requires argument
+ | OptArg (Maybe String -> a) String -- ^ optional argument
+
+data OptKind a -- kind of cmd line arg (internal use only):
+ = Opt a -- an option
+ | UnreqOpt String -- an un-recognized option
+ | NonOpt String -- a non-option
+ | EndOfOpts -- end-of-options marker (i.e. "--")
+ | OptErr String -- something went wrong...
+
+-- | Return a string describing the usage of a command, derived from
+-- the header (first argument) and the options described by the
+-- second argument.
+usageInfo :: String -- header
+ -> [OptDescr a] -- option descriptors
+ -> String -- nicely formatted decription of options
+usageInfo header optDescr = unlines (header:table)
+ where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr
+ table = zipWith3 paste (sameLen ss) (sameLen ls) ds
+ paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z
+ sameLen xs = flushLeft ((maximum . map length) xs) xs
+ flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
+
+fmtOpt :: OptDescr a -> [(String,String,String)]
+fmtOpt (Option sos los ad descr) =
+ case lines descr of
+ [] -> [(sosFmt,losFmt,"")]
+ (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
+ where sepBy _ [] = ""
+ sepBy _ [x] = x
+ sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
+ sosFmt = sepBy ',' (map (fmtShort ad) sos)
+ losFmt = sepBy ',' (map (fmtLong ad) los)
+
+fmtShort :: ArgDescr a -> Char -> String
+fmtShort (NoArg _ ) so = "-" ++ [so]
+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
+
+fmtLong :: ArgDescr a -> String -> String
+fmtLong (NoArg _ ) lo = "--" ++ lo
+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+
+{-|
+Process the command-line, and return the list of values that matched
+(and those that didn\'t). The arguments are:
+
+* The order requirements (see 'ArgOrder')
+
+* The option descriptions (see 'OptDescr')
+
+* The actual command line arguments (presumably got from
+ 'System.Environment.getArgs').
+
+'getOpt' returns a triple consisting of the option arguments, a list
+of non-options, and a list of error messages.
+-}
+getOpt :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String],[String]) -- (options,non-options,error messages)
+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
+ where (os,xs,us,es) = getOpt' ordering optDescr args
+
+{-|
+This is almost the same as 'getOpt', but returns a quadruple
+consisting of the option arguments, a list of non-options, a list of
+unrecognized options, and a list of error messages.
+-}
+getOpt' :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _ _ [] = ([],[],[],[])
+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
+ where procNextOpt (Opt o) _ = (o:os,xs,us,es)
+ procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
+ procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
+ procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
+ procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
+ procNextOpt EndOfOpts Permute = ([],rest,[],[])
+ procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
+ procNextOpt (OptErr e) _ = (os,xs,us,e:es)
+
+ (opt,rest) = getNext arg args optDescr
+ (os,xs,us,es) = getOpt' ordering optDescr rest
+
+-- take a look at the next cmd line arg and decide what to do with it
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
+getNext a rest _ = (NonOpt a,rest)
+
+-- handle long option
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt ls rs optDescr = long ads arg rs
+ where (opt,arg) = break (=='=') ls
+ getWith p = [ o | o@(Option _ xs _ _) <- optDescr
+ , find (p opt) xs /= Nothing ]
+ exact = getWith (==)
+ options = if null exact then getWith isPrefixOf else exact
+ ads = [ ad | Option _ _ ad _ <- options ]
+ optStr = ("--"++opt)
+
+ long (_:_:_) _ rest = (errAmbig options optStr,rest)
+ long [NoArg a ] [] rest = (Opt a,rest)
+ long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
+ long [ReqArg _ d] [] [] = (errReq d optStr,[])
+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)
+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
+ long _ _ rest = (UnreqOpt ("--"++ls),rest)
+
+-- handle short option
+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+shortOpt y ys rs optDescr = short ads ys rs
+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
+ ads = [ ad | Option _ _ ad _ <- options ]
+ optStr = '-':[y]
+
+ short (_:_:_) _ rest = (errAmbig options optStr,rest)
+ short (NoArg a :_) [] rest = (Opt a,rest)
+ short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
+ short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
+ short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
+ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
+ short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
+ short [] [] rest = (UnreqOpt optStr,rest)
+ short [] xs rest = (UnreqOpt optStr,('-':xs):rest)
+
+-- miscellaneous error formatting
+
+errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig ods optStr = OptErr (usageInfo header ods)
+ where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+
+errReq :: String -> String -> OptKind a
+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
+
+errUnrec :: String -> String
+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
+
+errNoArg :: String -> OptKind a
+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+
+{-
+-----------------------------------------------------------------------------------------
+-- and here a small and hopefully enlightening example:
+
+data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
+
+options :: [OptDescr Flag]
+options =
+ [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
+ Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
+ Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
+ Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
+
+out :: Maybe String -> Flag
+out Nothing = Output "stdout"
+out (Just o) = Output o
+
+test :: ArgOrder Flag -> [String] -> String
+test order cmdline = case getOpt order options cmdline of
+ (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
+ (_,_,errs) -> concat errs ++ usageInfo header options
+ where header = "Usage: foobar [OPTION...] files..."
+
+-- example runs:
+-- putStr (test RequireOrder ["foo","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["foo","-v"])
+-- ==> options=[Verbose] args=["foo"]
+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
+-- ==> options=[Arg "foo", Verbose] args=[]
+-- putStr (test Permute ["foo","--","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
+-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
+-- putStr (test Permute ["--ver","foo"])
+-- ==> option `--ver' is ambiguous; could be one of:
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- Usage: foobar [OPTION...] files...
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- -o[FILE] --output[=FILE] use FILE for dump
+-- -n USER --name=USER only dump USER's files
+-----------------------------------------------------------------------------------------
+-}
+
+{- $example1
+
+A simple choice for the type associated with flags is to define a type
+@Flag@ as an algebraic type representing the possible flags and their
+arguments:
+
+> module Opts1 where
+>
+> import System.Console.GetOpt
+> import Data.Maybe ( fromMaybe )
+>
+> data Flag
+> = Verbose | Version
+> | Input String | Output String | LibDir String
+> deriving Show
+>
+> options :: [OptDescr Flag]
+> options =
+> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
+> , Option ['V','?'] ["version"] (NoArg Version) "show version number"
+> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
+> , Option ['c'] [] (OptArg inp "FILE") "input FILE"
+> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
+> ]
+>
+> inp,outp :: Maybe String -> Flag
+> outp = Output . fromMaybe "stdout"
+> inp = Input . fromMaybe "stdin"
+>
+> compilerOpts :: [String] -> IO ([Flag], [String])
+> compilerOpts argv =
+> case getOpt Permute options argv of
+> (o,n,[] ) -> return (o,n)
+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+> where header = "Usage: ic [OPTION...] files..."
+
+Then the rest of the program will use the constructed list of flags
+to determine it\'s behaviour.
+
+-}
+
+{- $example2
+
+A different approach is to group the option values in a record of type
+@Options@, and have each flag yield a function of type
+@Options -> Options@ transforming this record.
+
+> module Opts2 where
+>
+> import System.Console.GetOpt
+> import Data.Maybe ( fromMaybe )
+>
+> data Options = Options
+> { optVerbose :: Bool
+> , optShowVersion :: Bool
+> , optOutput :: Maybe FilePath
+> , optInput :: Maybe FilePath
+> , optLibDirs :: [FilePath]
+> } deriving Show
+>
+> defaultOptions = Options
+> { optVerbose = False
+> , optShowVersion = False
+> , optOutput = Nothing
+> , optInput = Nothing
+> , optLibDirs = []
+> }
+>
+> options :: [OptDescr (Options -> Options)]
+> options =
+> [ Option ['v'] ["verbose"]
+> (NoArg (\ opts -> opts { optVerbose = True }))
+> "chatty output on stderr"
+> , Option ['V','?'] ["version"]
+> (NoArg (\ opts -> opts { optShowVersion = True }))
+> "show version number"
+> , Option ['o'] ["output"]
+> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")
+> "FILE")
+> "output FILE"
+> , Option ['c'] []
+> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")
+> "FILE")
+> "input FILE"
+> , Option ['L'] ["libdir"]
+> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")
+> "library directory"
+> ]
+>
+> compilerOpts :: [String] -> IO (Options, [String])
+> compilerOpts argv =
+> case getOpt Permute options argv of
+> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+> where header = "Usage: ic [OPTION...] files..."
+
+Similarly, each flag could yield a monadic function transforming a record,
+of type @Options -> IO Options@ (or any other monad), allowing option
+processing to perform actions of the chosen monad, e.g. printing help or
+version messages, checking that file arguments exist, etc.
+
+-}
--- /dev/null
+-------------------------------------------------------------------------------
+-- |
+-- Module : System.Timeout
+-- Copyright : (c) The University of Glasgow 2007
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Attach a timeout event to arbitrary 'IO' computations.
+--
+-------------------------------------------------------------------------------
+
+#ifdef __GLASGOW_HASKELL__
+#include "Typeable.h"
+#endif
+
+module System.Timeout ( timeout ) where
+
+#ifdef __GLASGOW_HASKELL__
+import Prelude (Show(show), IO, Ord((<)), Eq((==)), Int,
+ otherwise, fmap)
+import Data.Maybe (Maybe(..))
+import Control.Monad (Monad(..))
+import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
+import Control.Exception (Exception, handleJust, throwTo, bracket)
+import Data.Typeable
+import Data.Unique (Unique, newUnique)
+
+-- An internal type that is thrown as a dynamic exception to
+-- interrupt the running IO computation when the timeout has
+-- expired.
+
+data Timeout = Timeout Unique deriving Eq
+INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout")
+
+instance Show Timeout where
+ show _ = "<<timeout>>"
+
+instance Exception Timeout
+#endif /* !__GLASGOW_HASKELL__ */
+
+-- |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 :: Int -> IO a -> IO (Maybe a)
+#ifdef __GLASGOW_HASKELL__
+timeout n f
+ | n < 0 = fmap Just f
+ | n == 0 = return Nothing
+ | otherwise = do
+ pid <- myThreadId
+ ex <- fmap Timeout newUnique
+ handleJust (\e -> if e == ex then Just () else Nothing)
+ (\_ -> return Nothing)
+ (bracket (forkIO (threadDelay n >> throwTo pid ex))
+ (killThread)
+ (\_ -> fmap Just f))
+#else
+timeout n f = fmap Just f
+#endif /* !__GLASGOW_HASKELL__ */
projects / ghc-base.git / commitdiff