--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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
+ #-}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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 <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 (
+ 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
+-----------------------------------------------------------------------------------------
+-}
projects / ghc-base.git / commitdiff