From 23f43c48018638acbbf533447e74e08bf9fd789a Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 4 Jul 2001 10:48:39 +0000 Subject: [PATCH] [project @ 2001-07-04 10:48:39 by simonmar] Add 4 new libraries --- Data/Array/Diff.hs | 327 ++++++++++++++++++++++++++++++++++++++++++++++ Data/Array/Storable.hs | 82 ++++++++++++ Data/Unique.hs | 53 ++++++++ System/Console/GetOpt.hs | 217 ++++++++++++++++++++++++++++++ 4 files changed, 679 insertions(+) create mode 100644 Data/Array/Diff.hs create mode 100644 Data/Array/Storable.hs create mode 100644 Data/Unique.hs create mode 100644 System/Console/GetOpt.hs diff --git a/Data/Array/Diff.hs b/Data/Array/Diff.hs new file mode 100644 index 0000000..2ef109f --- /dev/null +++ b/Data/Array/Diff.hs @@ -0,0 +1,327 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.Diff +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Diff.hs,v 1.1 2001/07/04 10:48:39 simonmar Exp $ +-- +-- Functional arrays with constant-time update. +-- +----------------------------------------------------------------------------- + +module Data.Array.Diff ( + + -- Diff arrays have immutable interface, but rely on internal + -- updates in place to provide fast functional update operator + -- '//'. + -- + -- When the '//' operator is applied to a diff array, its contents + -- are physically updated in place. The old array silently changes + -- its representation without changing the visible behavior: + -- it stores a link to the new current array along with the + -- difference to be applied to get the old contents. + -- + -- So if a diff array is used in a single-threaded style, + -- i.e. after '//' application the old version is no longer used, + -- 'a!i' takes O(1) time and 'a // d' takes O(length d). Accessing + -- elements of older versions gradually becomes slower. + -- + -- Updating an array which is not current makes a physical copy. + -- The resulting array is unlinked from the old family. So you + -- can obtain a version which is guaranteed to be current and + -- thus have fast element access by 'a // []'. + + -- Possible improvement for the future (not implemented now): + -- make it possible to say "I will make an update now, but when + -- I later return to the old version, I want it to mutate back + -- instead of being copied". + + -- An arbitrary MArray type living in the IO monad can be converted + -- to a diff array. + IOToDiffArray, -- data IOToDiffArray + -- (a :: * -> * -> *) -- internal mutable array + -- (i :: *) -- indices + -- (e :: *) -- elements + + -- Two most important diff array types are fully polymorphic + -- lazy boxed DiffArray: + DiffArray, -- = IOToDiffArray IOArray + -- ...and strict unboxed DiffUArray, working only for elements + -- of primitive types but more compact and usually faster: + DiffUArray, -- = IOToDiffArray IOUArray + + -- Module IArray provides the interface of diff arrays. They are + -- instances of class IArray. + module Data.Array.IArray, + + -- These are really internal functions, but you will need them + -- to make further IArray instances of various DiffArrays (for + -- either more MArray types or more unboxed element types). + newDiffArray, readDiffArray, replaceDiffArray + ) + where + +------------------------------------------------------------------------ +-- Imports. + +import Prelude + +import Data.Ix +import Data.Array.Base +import Data.Array.IArray +import Data.Array.IO + +import Foreign.Ptr ( Ptr, FunPtr ) +import Foreign.StablePtr ( StablePtr ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Word ( Word, Word8, Word16, Word32, Word64) + +import System.IO.Unsafe ( unsafePerformIO ) +import Control.Concurrent ( MVar, newMVar, takeMVar, putMVar, readMVar ) + +------------------------------------------------------------------------ +-- Diff array types. + +-- Convert an IO array type to a diff array. +newtype IOToDiffArray a i e = + DiffArray {varDiffArray :: MVar (DiffArrayData a i e)} + +-- Internal representation: either a mutable array, or a link to +-- another diff array patched with a list of index+element pairs. +data DiffArrayData a i e = Current (a i e) + | Diff (IOToDiffArray a i e) [(Int, e)] + +-- Type synonyms for two most important IO array types. +type DiffArray = IOToDiffArray IOArray +type DiffUArray = IOToDiffArray IOUArray + +-- Having 'MArray a e IO' in instance context would require +-- -fallow-undecidable-instances, so each instance is separate here. + +------------------------------------------------------------------------ +-- Boring instances. + +instance HasBounds a => HasBounds (IOToDiffArray a) where + bounds a = unsafePerformIO $ boundsDiffArray a + +instance IArray (IOToDiffArray IOArray) e where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Char where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) (Ptr a) where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) (FunPtr a) where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Float where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Double where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) (StablePtr a) where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int8 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int16 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int32 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Int64 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word8 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word16 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word32 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +instance IArray (IOToDiffArray IOUArray) Word64 where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies + +------------------------------------------------------------------------ +-- The important stuff. + +newDiffArray :: (MArray a e IO, Ix i) + => (i,i) + -> [(Int, e)] + -> IO (IOToDiffArray a i e) +newDiffArray (l,u) ies = do + a <- newArray_ (l,u) + sequence_ [unsafeWrite a i e | (i, e) <- ies] + var <- newMVar (Current a) + return (DiffArray var) + +readDiffArray :: (MArray a e IO, Ix i) + => IOToDiffArray a i e + -> Int + -> IO e +a `readDiffArray` i = do + d <- readMVar (varDiffArray a) + case d of + Current a' -> unsafeRead a' i + Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies) + +replaceDiffArray :: (MArray a e IO, Ix i) + => IOToDiffArray a i e + -> [(Int, e)] + -> IO (IOToDiffArray a i e) +a `replaceDiffArray` ies = do + d <- takeMVar (varDiffArray a) + case d of + Current a' -> case ies of + [] -> do + -- We don't do the copy when there is nothing to change + -- and this is the current version. But see below. + putMVar (varDiffArray a) d + return a + _:_ -> do + diff <- sequence [do e <- unsafeRead a' i; return (i, e) + | (i, _) <- ies] + sequence_ [unsafeWrite a' i e | (i, e) <- ies] + var' <- newMVar (Current a') + putMVar (varDiffArray a) (Diff (DiffArray var') diff) + return (DiffArray var') + Diff _ _ -> do + -- We still do the copy when there is nothing to change + -- but this is not the current version. So you can use + -- 'a // []' to make sure that the resulting array has + -- fast element access. + putMVar (varDiffArray a) d + a' <- thawDiffArray a + -- thawDiffArray gives a fresh array which we can + -- safely mutate. + sequence_ [unsafeWrite a' i e | (i, e) <- ies] + var' <- newMVar (Current a') + return (DiffArray var') + +boundsDiffArray :: (HasBounds a, Ix ix) + => IOToDiffArray a ix e + -> IO (ix,ix) +boundsDiffArray a = do + d <- readMVar (varDiffArray a) + case d of + Current a' -> return (bounds a') + Diff a' _ -> boundsDiffArray a' + +freezeDiffArray :: (MArray a e IO, Ix ix) + => a ix e + -> IO (IOToDiffArray a ix e) +freezeDiffArray a | (l,u) <- bounds a = do + a' <- newArray_ (l,u) + sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]] + var <- newMVar (Current a') + return (DiffArray var) + +{-# RULES +"freeze/DiffArray" freeze = freezeDiffArray + #-} + +-- unsafeFreezeDiffArray is really unsafe. Better don't use the old +-- array at all after freezing. The contents of the source array will +-- be changed when '//' is applied to the resulting array. + +unsafeFreezeDiffArray :: (MArray a e IO, Ix ix) + => a ix e + -> IO (IOToDiffArray a ix e) +unsafeFreezeDiffArray a = do + var <- newMVar (Current a) + return (DiffArray var) + +{-# RULES +"unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray + #-} + +thawDiffArray :: (MArray a e IO, Ix ix) + => IOToDiffArray a ix e + -> IO (a ix e) +thawDiffArray a = do + d <- readMVar (varDiffArray a) + case d of + Current a' | (l,u) <- bounds a' -> do + a'' <- newArray_ (l,u) + sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]] + return a'' + Diff a' ies -> do + a'' <- thawDiffArray a' + sequence_ [unsafeWrite a'' i e | (i, e) <- ies] + return a'' + +{-# RULES +"thaw/DiffArray" thaw = thawDiffArray + #-} + +-- unsafeThawDiffArray is really unsafe. Better don't use the old +-- array at all after thawing. The contents of the resulting array +-- will be changed when '//' is applied to the source array. + +unsafeThawDiffArray :: (MArray a e IO, Ix ix) + => IOToDiffArray a ix e + -> IO (a ix e) +unsafeThawDiffArray a = do + d <- readMVar (varDiffArray a) + case d of + Current a' -> return a' + Diff a' ies -> do + a'' <- unsafeThawDiffArray a' + sequence_ [unsafeWrite a'' i e | (i, e) <- ies] + return a'' + +{-# RULES +"unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray + #-} diff --git a/Data/Array/Storable.hs b/Data/Array/Storable.hs new file mode 100644 index 0000000..e725d2d --- /dev/null +++ b/Data/Array/Storable.hs @@ -0,0 +1,82 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.Storable +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Storable.hs,v 1.1 2001/07/04 10:48:39 simonmar Exp $ +-- +-- A storable array is an IO-mutable array which stores its +-- contents in a contiguous memory block living in the C +-- heap. Elements are stored according to the class Storable. +-- You can obtain the pointer to the array contents to manipulate +-- elements from languages like C. +-- +-- It's similar to IOUArray but slower. Its advantage is that +-- it's compatible with C. +-- +----------------------------------------------------------------------------- + +module Data.Array.Storable ( + + -- Array type: + StorableArray, -- data StorableArray index element + -- -- index type must be in class Ix + -- -- element type must be in class Storable + + -- Module MArray provides the interface of storable arrays. + -- They are instances of class MArray (with IO monad). + module Data.Array.MArray, + + -- The pointer to the array contents is obtained by withStorableArray. + -- The idea is similar to ForeignPtr (used internally here). The + -- pointer should be used only during execution of the IO action + -- retured by the function passed as argument to withStorableArray: + withStorableArray, -- :: StorableArray i e -> (Ptr e -> IO a) -> IO a + + -- If you want to use it afterwards, ensure that you + -- touchStorableArray after the last use of the pointer, + -- so the array is not freed too early: + touchStorableArray -- :: StorableArray i e -> IO () + ) + where + +import Data.Array.Base +import Data.Array.MArray +import Foreign hiding (newArray) + +data StorableArray i e = StorableArray !i !i !(ForeignPtr e) + +instance HasBounds StorableArray where + bounds (StorableArray l u _) = (l,u) + +instance Storable e => MArray StorableArray e IO where + + newArray (l,u) init = do + a <- mallocArray size + sequence_ [pokeElemOff a i init | i <- [0..size-1]] + fp <- newForeignPtr a (free a) + return (StorableArray l u fp) + where + size = rangeSize (l,u) + + newArray_ (l,u) = do + a <- mallocArray (rangeSize (l,u)) + fp <- newForeignPtr a (free a) + return (StorableArray l u fp) + + unsafeRead (StorableArray _ _ fp) i = + withForeignPtr fp $ \a -> peekElemOff a i + + unsafeWrite (StorableArray _ _ fp) i e = + withForeignPtr fp $ \a -> pokeElemOff a i e + +withStorableArray :: StorableArray i e -> (Ptr e -> IO a) -> IO a +withStorableArray (StorableArray _ _ fp) f = withForeignPtr fp f + +touchStorableArray :: StorableArray i e -> IO () +touchStorableArray (StorableArray _ _ fp) = touchForeignPtr fp diff --git a/Data/Unique.hs b/Data/Unique.hs new file mode 100644 index 0000000..97251ff --- /dev/null +++ b/Data/Unique.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Unique +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Unique.hs,v 1.1 2001/07/04 10:48:39 simonmar Exp $ +-- +-- An infinite supply of unique objects, supporting ordering and equality. +-- +----------------------------------------------------------------------------- + +module Data.Unique ( + Unique, -- instance (Eq, Ord) + newUnique, -- :: IO Unique + hashUnique -- :: Unique -> Int + ) where + +import Prelude + +import Control.Concurrent +import System.IO.Unsafe (unsafePerformIO) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Num ( Integer(..) ) +#endif + +newtype Unique = Unique Integer deriving (Eq,Ord) + +uniqSource :: MVar Integer +uniqSource = unsafePerformIO (newMVar 0) +{-# NOINLINE uniqSource #-} + +newUnique :: IO Unique +newUnique = do + val <- takeMVar uniqSource + let next = val+1 + putMVar uniqSource next + return (Unique next) + +hashUnique :: Unique -> Int +#ifdef __GLASGOW_HASKELL__ +hashUnique (Unique (S# i)) = I# i +hashUnique (Unique (J# s d)) | s ==# 0# = 0 + | otherwise = I# (indexIntArray# d 0#) +#else +hashUnique (Unique u) = u `mod` (fromIntegral (maxBound :: Int) + 1) +#endif diff --git a/System/Console/GetOpt.hs b/System/Console/GetOpt.hs new file mode 100644 index 0000000..36c6095 --- /dev/null +++ b/System/Console/GetOpt.hs @@ -0,0 +1,217 @@ +----------------------------------------------------------------------------- +-- +-- Module : System.Console.GetOpt +-- Copyright : (c) Sven Panne Oct. 1996 (small changes Dec. 1997) +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- $Id: GetOpt.hs,v 1.1 2001/07/04 10:48:39 simonmar Exp $ +-- +-- A Haskell port of GNU's 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 ( + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + usageInfo, -- :: String -> [OptDescr a] -> String + getOpt -- :: ArgOrder a -> [OptDescr a] -> [String] + -- -> ([a],[String],[String]) + ) where + +import Data.List ( isPrefixOf ) + +data ArgOrder a -- what to do with options following non-options: + = RequireOrder -- no option processing after first non-option + | Permute -- freely intersperse options and non-options + | ReturnInOrder (String -> a) -- wrap non-options into options + +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 + +data ArgDescr a -- description of an argument option: + = 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 + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = (unzip3 . map 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) = (sepBy ',' (map (fmtShort ad) sos), + sepBy ',' (map (fmtLong ad) los), + descr) + where sepBy _ [] = "" + sepBy _ [x] = x + sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs + +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 ++ "]" + +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the commandline arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt _ _ [] = ([],[],[]) +getOpt ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[]) + procNextOpt EndOfOpts Permute = ([],rest,[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[]) + procNextOpt (OptErr e) _ = (os,xs,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,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 + options = [ o | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `isPrefixOf` l ] + 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 = (errUnrec optStr,rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt x xs rest optDescr = short ads xs rest + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[x] + + 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 = (errUnrec optStr,rest) + short [] xs rest = (errUnrec 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 -> OptKind a +errUnrec optStr = OptErr ("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 +----------------------------------------------------------------------------------------- +-} -- 1.7.10.4