From d07c47f3080ebae7bed4a94c258a90f07d911415 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Thu, 4 Sep 2008 10:09:51 +0000 Subject: [PATCH] Add missing files --- Control/Concurrent.hs | 636 +++++++++++++++++++++++++++++++++++++++ Control/Concurrent/Chan.hs | 132 ++++++++ Control/Concurrent/MVar.hs | 116 +++++++ Control/Concurrent/QSem.hs | 77 +++++ Control/Concurrent/QSemN.hs | 70 +++++ Control/Concurrent/SampleVar.hs | 117 +++++++ Data/Unique.hs | 59 ++++ System/Console/GetOpt.hs | 393 ++++++++++++++++++++++++ System/Timeout.hs | 88 ++++++ 9 files changed, 1688 insertions(+) create mode 100644 Control/Concurrent.hs create mode 100644 Control/Concurrent/Chan.hs create mode 100644 Control/Concurrent/MVar.hs create mode 100644 Control/Concurrent/QSem.hs create mode 100644 Control/Concurrent/QSemN.hs create mode 100644 Control/Concurrent/SampleVar.hs create mode 100644 Data/Unique.hs create mode 100644 System/Console/GetOpt.hs create mode 100644 System/Timeout.hs diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs new file mode 100644 index 0000000..7f252f2 --- /dev/null +++ b/Control/Concurrent.hs @@ -0,0 +1,636 @@ +{-# 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/ +. + +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\@ 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__ */ diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs new file mode 100644 index 0000000..12f75c9 --- /dev/null +++ b/Control/Concurrent/Chan.hs @@ -0,0 +1,132 @@ +----------------------------------------------------------------------------- +-- | +-- 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) diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs new file mode 100644 index 0000000..3513bbd --- /dev/null +++ b/Control/Concurrent/MVar.hs @@ -0,0 +1,116 @@ +----------------------------------------------------------------------------- +-- | +-- 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 diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs new file mode 100644 index 0000000..87f5543 --- /dev/null +++ b/Control/Concurrent/QSem.hs @@ -0,0 +1,77 @@ +----------------------------------------------------------------------------- +-- | +-- 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 () diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs new file mode 100644 index 0000000..014a72c --- /dev/null +++ b/Control/Concurrent/QSemN.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- 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') diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs new file mode 100644 index 0000000..69c29c2 --- /dev/null +++ b/Control/Concurrent/SampleVar.hs @@ -0,0 +1,117 @@ +----------------------------------------------------------------------------- +-- | +-- 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) + diff --git a/Data/Unique.hs b/Data/Unique.hs new file mode 100644 index 0000000..6f8c24f --- /dev/null +++ b/Data/Unique.hs @@ -0,0 +1,59 @@ +----------------------------------------------------------------------------- +-- | +-- 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 diff --git a/System/Console/GetOpt.hs b/System/Console/GetOpt.hs new file mode 100644 index 0000000..92ebd52 --- /dev/null +++ b/System/Console/GetOpt.hs @@ -0,0 +1,393 @@ +----------------------------------------------------------------------------- +-- | +-- 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 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. + +-} diff --git a/System/Timeout.hs b/System/Timeout.hs new file mode 100644 index 0000000..431f709 --- /dev/null +++ b/System/Timeout.hs @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------- +-- | +-- 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 _ = "<>" + +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__ */ -- 1.7.10.4