cmdargs 0.3 → 0.4

raw patch · 23 files changed

+916/−681 lines, 23 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Generics/Any.hs +18/−5
• Main.hs +0/−1
• System/Console/CmdArgs/Annotate.hs +278/−0
• System/Console/CmdArgs/Explicit.hs +1/−1
• System/Console/CmdArgs/Explicit/Help.hs +5/−0
• System/Console/CmdArgs/Explicit/Process.hs +13/−6
• System/Console/CmdArgs/Explicit/Type.hs +39/−16
• System/Console/CmdArgs/Implicit.hs +49/−13
• System/Console/CmdArgs/Implicit/Ann.hs +4/−4
• System/Console/CmdArgs/Implicit/Capture.hs +0/−120
• System/Console/CmdArgs/Implicit/Global.hs +218/−0
• System/Console/CmdArgs/Implicit/Local.hs +166/−0
• System/Console/CmdArgs/Implicit/Step1.hs +0/−176
• System/Console/CmdArgs/Implicit/Step2.hs +0/−128
• System/Console/CmdArgs/Implicit/Step3.hs +0/−189
• System/Console/CmdArgs/Implicit/Type.hs +45/−0
• System/Console/CmdArgs/Implicit/UI.hs +1/−3
• System/Console/CmdArgs/Test/Implicit/HLint.hs +6/−3
• System/Console/CmdArgs/Test/Implicit/Maker.hs +35/−4
• System/Console/CmdArgs/Test/Implicit/Tests.hs +16/−6
• System/Console/CmdArgs/Test/Implicit/Util.hs +17/−0
• System/Console/CmdArgs/Text.hs +0/−1
• cmdargs.cabal +5/−5

@@ -22,19 +22,24 @@ --------------------------------------------------------------------- -- BASIC TYPES +-- | Any value, with a Data dictionary. data Any = forall a . Data a => Any a+ type AnyT t = Any  instance Show Any where     show = show . typeOf -fromAny :: Data a => Any -> a-fromAny (Any x) = case cast x of+fromAny :: Typeable a => Any -> a+fromAny (Any x) = case D.cast x of     Just y -> y     ~(Just y) -> error $ "Data.Generics.Any.fromAny: Failed to extract any, got " ++                          show (D.typeOf x) ++ ", wanted " ++ show (D.typeOf y)  +cast :: Typeable a => Any -> Maybe a+cast (Any x) = D.cast x+ --------------------------------------------------------------------- -- SYB COMPATIBILITY @@ -82,9 +87,17 @@   recompose :: Any -> [Any] -> Any-recompose (Any x) cs = Any $ res `asTypeOf` x-    where res = flip evalState cs $ flip fromConstrM (D.toConstr x) $ do-                    c:cs <- get; put cs; return $ fromAny c+recompose (Any x) cs | null s = Any $ res `asTypeOf` x+                     | otherwise = err+    where (res,s) = flip runState cs $ flip fromConstrM (D.toConstr x) $ do+                        cs <- get+                        if null cs then err else do+                            put $ tail cs+                            return $ fromAny $ head cs++          err = error $ "Data.Generics.Any.recompose: Incorrect number of children to recompose, " +++                        ctor (Any x) ++ " :: " ++ show (Any x) ++ ", expected " ++ show (arity $ Any x) +++                        ", got " ++ show (length cs)   ctors :: Any -> [CtorName]

@@ -1,4 +1,3 @@-{-# LANGUAGE PatternGuards #-}  module Main where 

@@ -0,0 +1,278 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable #-}++-- | This module captures annotations on a value, and builds a 'Capture' value.+--   This module has two ways of writing annotations:+--+--   /Impure/: The impure method of writing annotations is susceptible to over-optimisation by GHC+--   - sometimes @\{\-\# OPTIONS_GHC -fno-cse \#\-\}@ will be required.+--+--   /Pure/: The pure method is more verbose, and lacks some type safety.+--+--   As an example of the two styles:+--+-- > data Foo = Foo {foo :: Int, bar :: Int}+--+--   @ impure = 'capture' $ Foo {foo = 12, bar = 'many' [1 '&=' \"inner\", 2]} '&=' \"top\"@+--+--   @ pure = 'capture_' $ 'record' Foo{} [foo := 12, bar :=+ ['atom' 1 '+=' \"inner\", 'atom' 2]] '+=' \"top\"@+--+--   Both evaluate to:+--+-- > Capture (Ann "top") (Ctor (Foo 12 1) [Value 12, Many [Ann "inner" (Value 1), Value 2]]+module System.Console.CmdArgs.Annotate(+    -- * Capture framework+    Capture(..), Any(..), fromCapture, defaultMissing,+    -- * Impure+    capture, many, (&=),+    -- * Pure+    capture_, many_, (+=), atom, record, Annotate((:=),(:=+))+    ) where++import Control.Monad+import Control.Monad.State+import Data.Data(Data,Typeable)+import Data.List+import Data.Maybe+import Data.IORef+import System.IO.Unsafe+import Control.Exception+import Data.Generics.Any++infixl 2 &=, +=+infix 3 :=+++-- | The result of capturing some annotations.+data Capture ann+    = Many [Capture ann] -- ^ Many values collapsed ('many' or 'many_')+    | Ann ann (Capture ann) -- ^ An annotation attached to a value ('&=' or '+=')+    | Value Any -- ^ A value (just a value, or 'atom')+    | Missing Any -- ^ A missing field (a 'RecConError' exception, or missing from 'record')+    | Ctor Any [Capture ann] -- ^ A constructor (a constructor, or 'record')+      deriving Show++instance Functor Capture where+    fmap f (Many xs) = Many $ map (fmap f) xs+    fmap f (Ann a x) = Ann (f a) $ fmap f x+    fmap f (Value x) = Value x+    fmap f (Missing x) = Missing x+    fmap f (Ctor x xs) = Ctor x $ map (fmap f) xs+++-- | Return the value inside a capture.+fromCapture :: Capture ann -> Any+fromCapture (Many (x:_)) = fromCapture x+fromCapture (Ann _ x) = fromCapture x+fromCapture (Value x) = x+fromCapture (Missing x) = x+fromCapture (Ctor x _) = x+++-- | Remove all Missing values by using any previous instances as default values+defaultMissing :: Capture ann -> Capture ann+defaultMissing x = evalState (f Nothing Nothing x) []+    where+        f ctor field (Many xs) = fmap Many $ mapM (f ctor field) xs+        f ctor field (Ann a x) = fmap (Ann a) $ f ctor field x+        f ctor field (Value x) = return $ Value x+        f (Just ctor) (Just field) (Missing x) = do+            s <- get+            return $ head $+                [x2 | (ctor2,field2,x2) <- s, typeOf ctor == typeOf ctor2, field == field2] +++                err ("missing value encountered, no field for " ++ field ++ " (of type " ++ show x ++ ")")+        f _ _ (Missing x) = err $ "missing value encountered, but not as a field (of type " ++ show x ++ ")"+        f _ _ (Ctor x xs) | length (fields x) == length xs = do+            ys <- zipWithM (g x) (fields x) xs+            return $ Ctor (recompose x $ map fromCapture ys) ys+        f _ _ (Ctor x xs) = fmap (Ctor x) $ mapM (f Nothing Nothing) xs++        g ctor field x = do+            y <- f (Just ctor) (Just field) x+            modify ((ctor,field,y):)+            return y++        err x = error $ "System.Console.CmdArgs.Annotate.defaultMissing, " ++ x++---------------------------------------------------------------------+-- IMPURE BIT++-- test = show $ capture $ many [Just ((66::Int) &= P 1 &= P 2), Nothing &= P 8] &= P 3++{-+Notes On Purity+---------------++There is a risk that things that are unsafe will be inlined. That can generally be+removed by NOININE on everything.++There is also a risk that things get commoned up. For example:++foo = trace "1" 1+bar = trace "1" 1+main = do+    evaluate foo+    evaluate bar++Will print "1" only once, since foo and bar share the same pattern. However, if+anything in the value is a lambda they are not seen as equal. We exploit this by+defining const_ and id_ as per this module.++Now anything wrapped in id_ looks different from anything else.+-}+++{-+The idea is to keep a stack of either continuations, or values+If you encounter 'many' you become a value+If you encounter '&=' you increase the continuation+-}++{-# NOINLINE ref #-}+ref :: IORef [Either (Capture Any -> Capture Any) (Capture Any)]+ref = unsafePerformIO $ newIORef []++push = modifyIORef ref (Left id :)+pop = do x:xs <- readIORef ref; writeIORef ref xs; return x+change f = modifyIORef ref $ \x -> case x of Left g : rest -> f g : rest ; _ -> error "Internal error in Capture"+add f = change $ \x -> Left $ x . f+set x = change $ \f -> Right $ f x+++-- | Collapse multiple values in to one.+{-# NOINLINE many #-}+many :: Data val => [val] -> val+many xs = unsafePerformIO $ do+    ys <- mapM (force . Any) xs+    set $ Many ys+    return $ head xs+++{-# NOINLINE addAnn #-}+addAnn :: (Data val, Data ann) => val -> ann -> val+addAnn x y = unsafePerformIO $ do+    add (Ann $ Any y)+    evaluate x+    return x+++-- | Capture a value. Note that if the value is evaluated+--   more than once the result may be different, i.e.+--+-- > capture x /= capture x+{-# NOINLINE capture #-}+capture :: (Data val, Data ann) => val -> Capture ann+capture x = unsafePerformIO $ fmap (fmap fromAny) $ force $ Any x+++force :: Any -> IO (Capture Any)+force x@(Any xx) = do+    push+    res <- try $ evaluate xx+    y <- pop+    case y of+        _ | Left (_ :: RecConError) <- res -> return $ Missing x+        Right r -> return r+        Left f | not $ isAlgType x -> return $ f $ Value x+               | otherwise -> do+            cs <- mapM force $ children x+            return $ f $ Ctor x cs+++-- | Add an annotation to a value.+--+--   It is recommended that anyone making use of this function redefine+--   it with a more restrictive type signature to control the type of the+--   annotation (the second argument). Any redefinitions of this function+--   should add an INLINE pragma, to reduce the chance of incorrect+--   optimisations.+{-# INLINE (&=) #-}+(&=) :: (Data val, Data ann) => val -> ann -> val+(&=) x y = addAnn (id_ x) (id_ y)+++{-# NOINLINE const_ #-}+const_ :: a -> b -> b+const_ f x = x++{-# INLINE id_ #-}+id_ :: a -> a+id_ x = const_ (\() -> ()) x+++---------------------------------------------------------------------+-- PURE PART++-- | This type represents an annotated value. The type of the underlying value is not specified.+data Annotate ann+    = forall c f . (Data c, Data f) => (c -> f) := f -- ^ Construct a field, @fieldname := value@.+    | forall c f . (Data c, Data f) => (c -> f) :=+ [Annotate ann] -- ^ Add annotations to a field.+    | AAnn ann (Annotate ann)+    | AMany [Annotate ann]+    | AAtom Any+    | ACtor Any [Annotate ann]+++-- | Add an annotation to a value.+(+=) :: Annotate ann -> ann -> Annotate ann+(+=) = flip AAnn++-- | Collapse many annotated values in to one.+many_ :: [Annotate a] -> Annotate a+many_ = AMany++-- | Lift a pure value to an annotation.+atom :: Data val => val -> Annotate ann+atom = AAtom . Any++-- | Create a constructor/record. The first argument should be+--   the type of field, the second should be a list of fields constructed+--   originally defined by @:=@ or @:=+@.+--+--   This operation is not type safe, and may raise an exception at runtime+--   if any field has the wrong type or label.+record :: Data a => a -> [Annotate b] -> Annotate b+record a b = ACtor (Any a) b++-- | Capture the annotations from an annotated value.+capture_ :: Show a => Annotate a -> Capture a+capture_ (AAnn a x) = Ann a (capture_ x)+capture_ (AMany xs) = Many (map capture_ xs)+capture_ (AAtom x) = Value x+capture_ (_ := c) = Value $ Any c+capture_ (_ :=+ c) = Many $ map capture_ c+capture_ (ACtor x xs)+    | not $ null rep = error $ "Some fields got repeated under " ++ show x ++ "." ++ ctor x ++ ": " ++ show rep+    | otherwise = Ctor x2 xs2+    where+        x2 = recompose x $ map fromCapture xs2+        xs2 = [fromMaybe (Missing c) $ lookup i is | let is = zip inds $ map capture_ xs, (i,c) <- zip [0..] $ children x]+        inds = zipWith fromMaybe [0..] $ map (fieldIndex x) xs+        rep = inds \\ nub inds+++fieldIndex :: Any -> Annotate a -> Maybe Int+fieldIndex ctor (AAnn a x) = fieldIndex ctor x+fieldIndex ctor (f := _) = fieldIndex ctor (f :=+ [])+fieldIndex ctor (f :=+ _) | isJust res = res+                          | otherwise = error $ "Couldn't resolve field for " ++ show ctor+    where c = recompose ctor [Any $ throwInt i `asTypeOf` x | (i,Any x) <- zip [0..] (children ctor)]+          res = catchInt $ f $ fromAny c+fieldIndex _ _ = Nothing++++data ExceptionInt = ExceptionInt Int deriving (Show, Typeable)+instance Exception ExceptionInt+++throwInt :: Int -> a+throwInt i = throw (ExceptionInt i)+++{-# NOINLINE catchInt #-}+catchInt :: a -> Maybe Int+catchInt x = unsafePerformIO $ do+    y <- try (evaluate x)+    return $ case y of+        Left (ExceptionInt z) -> Just z+        _ -> Nothing

@@ -48,7 +48,7 @@     module System.Console.CmdArgs.Explicit.Help     ) where -import System.Console.CmdArgs.Explicit.Type+import System.Console.CmdArgs.Explicit.Type hiding (showRecord, (*=)) import System.Console.CmdArgs.Explicit.Process import System.Console.CmdArgs.Explicit.Help import System.Console.CmdArgs.Default

@@ -64,6 +64,11 @@ instance Show (Mode a) where     show = show . helpTextDefault +instance Show (Flag a) where+    show = show . helpFlag++instance Show (Arg a) where+    show = show . argType  -- | Generate a help message from a mode. helpText :: HelpFormat -> Mode a -> [Text]

@@ -58,6 +58,11 @@     ,errs :: [String]     } +stop :: S a -> Maybe (Either String a)+stop s | not $ null $ errs s = Just $ Left $ last $ errs s+       | null $ args s = Just $ Right $ val s+       | otherwise = Nothing+ err :: S a -> String -> S a err s x = s{errs=x:errs s} @@ -69,10 +74,7 @@  processFlags :: Mode a -> a -> [String] -> Either String a processFlags mode val_ args_ = f $ S val_ args_ []-    where-        f s | not $ null $ errs s = Left $ last $ errs s-            | null $ args s = Right $ val s-            | otherwise = f (processFlag mode s)+    where f s = fromMaybe (f $ processFlag mode s) $ stop s   pickFlags long mode = [(filter (\x -> (length x > 1) == long) $ flagNames flag,(flagInfo flag,flag)) | flag <- modeFlags mode]@@ -114,14 +116,19 @@         s = s_{args=ys}  -processFlag mode s_ =+processFlag mode s_@S{args="--":ys} = f s_{args=ys}+    where f s | isJust $ stop s = s+              | otherwise = f $ processArg mode s++processFlag mode s = processArg mode s++processArg mode s_@S{args=x:ys} =     case modeArgs mode of         Nothing -> err s $ "Unhandled argument, none expected: " ++ x         Just arg -> case argValue arg x (val s) of             Left e -> err s $ "Unhandled argument, " ++ e ++ ": " ++ x             Right v -> s{val=v}     where-        x:ys = if head (args s_) == "--" then tail (args s_) else args s_         s = s_{args=ys}  

@@ -63,6 +63,10 @@ --------------------------------------------------------------------- -- TYPES +showRecord x ys = x ++ " {" ++ intercalate ", " ys ++ "}"+a *= b = a ++ " = " ++ show b++ -- | A mode. Each mode has three main features: -- --   * A list of submodes ('modeGroupModes')@@ -103,7 +107,7 @@     | FlagOpt String      -- ^ Optional argument     | FlagOptRare String  -- ^ Optional argument that requires an = before the value     | FlagNone            -- ^ No argument-      deriving (Eq,Ord)+      deriving (Eq,Ord,Show)  -- | Extract the value from inside a 'FlagOpt' or 'FlagOptRare', or raises an error. fromFlagOpt :: FlagInfo -> String@@ -123,12 +127,22 @@     ,flagHelp :: Help -- ^ The help message associated with this flag.     } --- | An unnamed argument.++-- | An unnamed argument. Anything not starting with @-@ is considered an argument,+--   apart from @\"-\"@ which is considered to be the argument @\"-\"@, and any arguments+--   following @\"--\"@. For example:+--+-- > programname arg1 -j - --foo arg3 -- -arg4 --arg5=1 arg6+--+--   Would have the arguments:+--+-- > ["arg1","-","arg3","-arg4","--arg5=1","arg6"] data Arg a = Arg     {argValue :: Update a -- ^ A way of processing the argument.     ,argType :: FlagHelp -- ^ The type of data for the argument, i.e. FILE\/DIR\/EXT     } + --------------------------------------------------------------------- -- CHECK FLAGS @@ -160,20 +174,29 @@ --------------------------------------------------------------------- -- REMAP --- | Change the underlying type of a 'Mode' structure.-remap :: (a -> b) -- ^ Embed the mode-      -> (b -> (a, a -> b)) -- ^ Extract the mode and give a way of re-embedding-      -> Mode a -> Mode b-remap f g x = x-    {modeGroupModes = fmap (remap f g) $ modeGroupModes x-    ,modeValue = f $ modeValue x-    ,modeCheck = \v -> let (a,b) = g v in fmap b $ modeCheck x a-    ,modeArgs = fmap remapArg $ modeArgs x-    ,modeGroupFlags = fmap remapFlag $ modeGroupFlags x}-    where-        remapUpdate upd = \s v -> let (a,b) = g v in fmap b $ upd s a-        remapFlag x = x{flagValue = remapUpdate $ flagValue x}-        remapArg x = x{argValue = remapUpdate $ argValue x}+class Remap m where+    remap :: (a -> b) -- ^ Embed a value+          -> (b -> (a, a -> b)) -- ^ Extract the mode and give a way of re-embedding+          -> m a -> m b++remap2 :: Remap m => (a -> b) -> (b -> a) -> m a -> m b+remap2 f g = remap f (\x -> (g x, f))++instance Remap Mode where+    remap f g x = x+        {modeGroupModes = fmap (remap f g) $ modeGroupModes x+        ,modeValue = f $ modeValue x+        ,modeCheck = \v -> let (a,b) = g v in fmap b $ modeCheck x a+        ,modeArgs = fmap (remap f g) $ modeArgs x+        ,modeGroupFlags = fmap (remap f g) $ modeGroupFlags x}++instance Remap Flag where+    remap f g x = x{flagValue = remapUpdate f g $ flagValue x}++instance Remap Arg where+    remap f g x = x{argValue = remapUpdate f g $ argValue x}++remapUpdate f g upd = \s v -> let (a,b) = g v in fmap b $ upd s a   ---------------------------------------------------------------------

@@ -46,12 +46,15 @@ -} module System.Console.CmdArgs.Implicit(     -- * Running command lines-    cmdArgs, cmdArgsMode, cmdArgsRun, cmdArgsApply, CmdArgs(..),+    cmdArgs, cmdArgsMode, cmdArgsRun, cmdArgs_, cmdArgsMode_, cmdArgsApply, CmdArgs(..),     -- * Constructing command lines     -- | Attributes can work on a flag (inside a field), on a mode (outside the record),     --   or on all modes (outside the 'modes' call).-    (&=), modes, enum,     module System.Console.CmdArgs.Implicit.UI,+    -- ** Impure+    (&=), modes, enum,+    -- ** Pure+    (+=), record, atom, Annotate((:=)), enum_, modes_,     -- * Re-exported for convenience     -- | Provides a few opaque types (for writing type signatures),     --   verbosity control, default values with 'def' and the@@ -67,32 +70,49 @@ import System.Exit import System.Console.CmdArgs.Explicit(Mode,processArgs,remap) import System.Console.CmdArgs.Implicit.Ann-import System.Console.CmdArgs.Implicit.Capture-import System.Console.CmdArgs.Implicit.Step1-import System.Console.CmdArgs.Implicit.Step2-import System.Console.CmdArgs.Implicit.Step3+import System.Console.CmdArgs.Annotate hiding ((&=))+import qualified System.Console.CmdArgs.Annotate as A((&=))+import System.Console.CmdArgs.Implicit.Type+import System.Console.CmdArgs.Implicit.Local+import System.Console.CmdArgs.Implicit.Global import System.Console.CmdArgs.Implicit.UI import System.Console.CmdArgs.Verbosity import System.Console.CmdArgs.Default  --- | Take annotated records and run the corresponding command line.+-- | Take impurely annotated records and run the corresponding command line. --   Shortcut for @'cmdArgsRun' . 'cmdArgsMode'@. cmdArgs :: Data a => a -> IO a cmdArgs = cmdArgsRun . cmdArgsMode  --- | Take annotated records and turn them in to a 'Mode' value, that can+-- | Take purely annotated records and run the corresponding command line.+--   Shortcut for @'cmdArgsRun' . 'cmdArgsMode_'@.+cmdArgs_ :: Data a => Annotate Ann -> IO a+cmdArgs_ = cmdArgsRun . cmdArgsMode_+++cmdArgsCapture :: Data a => Capture Ann -> Mode (CmdArgs a)+cmdArgsCapture = remap embed proj . global . local+    where embed = fmap fromAny+          proj x = (fmap Any x, embed)+++-- | Take impurely annotated records and turn them in to a 'Mode' value, that can --   make use of the "System.Console.CmdArgs.Explicit" functions (i.e. 'process'). -- --   Annotated records are impure, and will only contain annotations on --   their first use. The result of this function is pure, and can be reused. cmdArgsMode :: Data a => a -> Mode (CmdArgs a)-cmdArgsMode = remap embed proj . step3 . step2 . step1 . capture . Any-    where embed = fmap fromAny-          proj x = (fmap Any x, embed)+cmdArgsMode = cmdArgsCapture . capture  +-- | Take purely annotated records and turn them in to a 'Mode' value, that can+--   make use of the "System.Console.CmdArgs.Explicit" functions (i.e. 'process').+cmdArgsMode_ :: Data a => Annotate Ann -> Mode (CmdArgs a)+cmdArgsMode_ = cmdArgsCapture . capture_++ -- | Run a Mode structure. This function reads the command line arguments --   and then performs as follows: --@@ -137,7 +157,7 @@ -- -- > data Modes = Mode1 | Mode2 | Mode3 deriving Data -- > cmdArgs $ modes [Mode1,Mode2,Mode3]-modes :: Data a => [a] -> a+modes :: Data val => [val] -> val modes = many  -- | Flag: \"I want several different flags to set this one field to different values.\"@@ -150,5 +170,21 @@ -- > cmdArgs $ Mode {state = enum [On &= help "Turn on",Off &= help "Turn off"]} -- >   --on   Turn on -- >   --off  Turn off-enum :: Data a => [a] -> a+enum :: Data val => [val] -> val enum = many+++-- | Add an annotation to a value. Note that if the value is evaluated+--   more than once the annotation will only be available the first time.+{-# INLINE (&=) #-}+(&=) :: Data val => val -> Ann -> val+(&=) = (A.&=)+++enum_ :: (Data c, Data f) => (c -> f) -> [Annotate Ann] -> Annotate Ann+enum_ = (:=+)++modes_ :: [Annotate Ann] -> Annotate Ann+modes_ = many_++

@@ -1,7 +1,9 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable #-}  module System.Console.CmdArgs.Implicit.Ann where +import Data.Data+ -- | The general type of annotations that can be associated with a value. data Ann     = Help String@@ -13,8 +15,6 @@     | FlagArgs     | FlagArgPos Int     | FlagType String-    | FlagEnum -- private, specified by 'one'-    | FlagInherit -- private, specified by omitting it (which throws RecConError)      | ModeDefault     | ModeHelpSuffix [String]@@ -22,4 +22,4 @@     | ProgSummary String     | ProgProgram String     | ProgVerbosity-      deriving (Eq,Ord,Show)+      deriving (Eq,Ord,Show,Data,Typeable)

@@ -1,120 +0,0 @@-{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}---- | This module does all the tricky/unsafe bits of CmdArgs.---   It captures annotations on the data structure in the most direct way---   possible.-module System.Console.CmdArgs.Implicit.Capture(-    Capture(..), capture, many, (&=)-    ) where--{--Notes on purity:--There is a risk that things that are unsafe will be inlined. That can generally be-removed by NOININE on everything.--There is also a risk that things get commoned up. For example:--foo = trace "1" 1-bar = trace "1" 1-main = do-    evaluate foo-    evaluate bar--Will print "1" only once, since foo and bar share the same pattern. However, if-anything in the value is a lambda they are not seen as equal. We exploit this by-defining const_ and id_ as per this module.--Now anything wrapped in id_ looks different from anything else.--}---import Data.Data(Data)-import Data.IORef-import System.IO.Unsafe-import Control.Exception-import System.Console.CmdArgs.Implicit.Ann-import Data.Generics.Any----- test = show $ capture $ many [Just ((66::Int) &= P 1 &= P 2), Nothing &= P 8] &= P 3---infixl 2 &=--data Capture-    = Many [Capture]-    | Ann Ann Capture-    | Value Any-    | Missing Any -- a RecConError-    | Ctor Any [Capture]-      deriving Show-      -{--The idea is to keep a stack of either continuations, or values-If you encounter 'many' you become a value-If you encounter '&=' you increase the continuation--}--{-# NOINLINE ref #-}-ref :: IORef [Either (Capture -> Capture) Capture]-ref = unsafePerformIO $ newIORef []--push = modifyIORef ref (Left id :)-pop = do x:xs <- readIORef ref; writeIORef ref xs; return x-modify f = modifyIORef ref $ \x -> case x of Left g : rest -> f g : rest ; _ -> error "Internal error in Capture"-add f = modify $ \x -> Left $ x . f-set x = modify $ \f -> Right $ f x----- | Collapse multiple values in to one.-{-# NOINLINE many #-}-many :: Data a => [a] -> a-many xs = unsafePerformIO $ do-    ys <- mapM (force . Any) xs-    set $ Many ys-    return $ head xs----- | Add an annotation to a value. Note that if the value is evaluated---   more than once the annotation will only be available the first time.-{-# NOINLINE addAnn #-}-addAnn :: Data a => a -> Ann -> a-addAnn x y = unsafePerformIO $ do-    add (Ann y)-    evaluate x-    return x---{-# NOINLINE capture #-}-capture :: Any -> Capture-capture x = unsafePerformIO $ force x---force :: Any -> IO Capture-force x@(Any xx) = do-    push-    res <- try $ evaluate xx-    y <- pop-    case y of-        _ | Left (_ :: RecConError) <- res -> return $ Missing x-        Right r -> return r-        Left f | not $ isAlgType x -> return $ f $ Value x-               | otherwise -> do-            cs <- mapM force $ children x-            return $ f $ Ctor x cs---{-# INLINE (&=) #-}-(&=) :: Data a => a -> Ann -> a-(&=) x y = addAnn (id_ x) (id_ y)---{-# NOINLINE const_ #-}-const_ :: a -> b -> b-const_ f x = x--{-# INLINE id_ #-}-id_ :: a -> a-id_ x = const_ (\() -> ()) x-

@@ -0,0 +1,218 @@+{-# LANGUAGE PatternGuards #-}++module System.Console.CmdArgs.Implicit.Global(global) where++import System.Console.CmdArgs.Implicit.Local+import System.Console.CmdArgs.Implicit.Type+import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Text+import System.Console.CmdArgs.Default++import Control.Monad+import Data.Char+import Data.Function+import Data.Generics.Any+import Data.List+import Data.Maybe+++global :: Prog_ -> Mode (CmdArgs Any)+global x = setHelp x $ collapse $ assignGroups $ assignNames $ extraFlags x+++---------------------------------------------------------------------+-- COLLAPSE THE FLAGS/MODES UPWARDS++collapse :: Prog_ -> Mode (CmdArgs Any)+collapse x | length ms == 1 = (head ms){modeNames=[progProgram x]}+           | length auto > 1 = err "prog" "Multiple automatic modes"+           | otherwise = (head $ map zeroMode auto ++ map emptyMode ms){modeNames=[progProgram x], modeGroupModes = toGroup ms}+    where+        ms = map collapseMode $ progModes x+        auto = [m | (m,True) <- zip ms $ map modeDefault $ progModes x]+++-- | A mode devoid of all it's contents+emptyMode :: Mode (CmdArgs Any) -> Mode (CmdArgs Any)+emptyMode x = x+    {modeCheck = \x -> if cmdArgsHasValue x then Left "No mode given and no default mode" else Right x+    ,modeGroupFlags = groupUncommonDelete $ modeGroupFlags x+    ,modeArgs=Nothing, modeHelpSuffix=[]}++-- | A mode whose help hides all it's contents+zeroMode :: Mode (CmdArgs Any) -> Mode (CmdArgs Any)+zeroMode x = x+    {modeGroupFlags = groupUncommonHide $ modeGroupFlags x+    ,modeArgs=fmap (\x -> x{argType=""}) $ modeArgs x+    ,modeHelpSuffix=[]}+++collapseMode :: Mode_ -> Mode (CmdArgs Any)+collapseMode x =+    collapseArgs [x | x@Arg_{} <- modeFlags_ x] $+    collapseFlags [x | x@Flag_{} <- modeFlags_ x] $+    modeMode x+++collapseFlags :: [Flag_] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)+collapseFlags xs x = x{modeGroupFlags = Group (pick Nothing) [] [(g, pick $ Just g) | g <- groups]}+    where+        pick x = map flagFlag $ filter ((==) x . flagGroup) xs+        groups = nub $ mapMaybe flagGroup xs+++collapseArgs :: [Flag_] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)+collapseArgs [] x = x+collapseArgs xs x = x{modeCheck=chk, modeArgs = Just $ flagArg upd hlp}+    where+        argUpd = argValue . flagArg_++        (ord,rep) = orderArgs xs+        mn = length $ dropWhile (isJust . flagArgOpt) $ reverse ord++        chk v | not $ cmdArgsHasValue v = Right v+              | n < mn = Left $ "Requires at least " ++ show mn ++ " arguments, got " ++ show n+              | otherwise = foldl f (addOptArgs n v) (drop n ord)+            where n = getArgsSeen v+                  f (Right v) arg = argUpd arg (fromJust $ flagArgOpt arg) v+                  f x _ = x++        -- if we have repeating args which is also opt, translate that here+        addOptArgs n v+            | Just x <- rep, Just o <- flagArgOpt x, Just n <= findIndex (isNothing . flagArgPos) (ord ++ [x]) = argUpd x o v+            | otherwise = Right v++        hlp = unwords $ a ++ map (\x -> "["++x++"]") b+            where (a,b) = splitAt mn $ map (argType . flagArg_) $ ord ++ maybeToList rep++        upd s v | n < length ord = argUpd (ord !! n) s v2+                | Just x <- rep = argUpd x s v2+                | otherwise = Left $ "expected at most " ++ show (length ord)+            where n = getArgsSeen v+                  v2 = incArgsSeen v+++-- return the arguments in order, plus those at the end+orderArgs :: [Flag_] -> ([Flag_], Maybe Flag_)+orderArgs args = (f 0 ord, listToMaybe rep)+    where+        (rep,ord) = span (isNothing . flagArgPos) $ sortBy (compare `on` flagArgPos) args+        f i [] = []+        f i (x:xs) = case fromJust (flagArgPos x) `compare` i of+            LT -> f i xs+            EQ -> x : f (i+1) xs+            GT -> take 1 rep ++ f (i+1) (x:xs)+++incArgsSeen x = x{cmdArgsPrivate = CmdArgsPrivate $ getArgsSeen x + 1}+getArgsSeen CmdArgs{cmdArgsPrivate = CmdArgsPrivate i} = i+++---------------------------------------------------------------------+-- DEAL WITH GROUPS++assignGroups :: Prog_ -> Prog_+assignGroups p = assignCommon $ p{progModes = map (\m -> m{modeFlags_ = f Nothing $ modeFlags_ m}) $ progModes p}+    where+        f grp [] = []+        f grp (x@Flag_{}:xs) = x{flagGroup=grp2} : f grp2 xs+            where grp2 = flagGroup x `mplus` grp+        f grp (x:xs) = x : f grp xs+++assignCommon :: Prog_ -> Prog_+assignCommon p =+    p{progModes = [m{modeFlags_ =+        [if isFlag_ f && show (flagFlag f) `elem` com then f{flagGroup = Just commonGroup} else f | f <- modeFlags_ m]}+    | m <- progModes p]}+    where+        com = map head $ filter ((== length (progModes p)) . length) $ group $ sort+              [show $ flagFlag f | m <- progModes p, f@Flag_{flagGroup=Nothing} <- modeFlags_ m]+++commonGroup = "Common flags"++groupSplitCommon :: Group a -> ([a], Group a)+groupSplitCommon (Group unnamed hidden named) = (concatMap snd com, Group unnamed hidden uni)+    where (com,uni) = partition ((==) commonGroup . fst) named++groupCommonHide x = let (a,b) = groupSplitCommon x in b{groupHidden = groupHidden b ++ a}+groupUncommonHide x = let (a,b) = groupSplitCommon x in Group [] (fromGroup b) [(commonGroup,a) | not $ null a]+groupUncommonDelete x = let a = fst $ groupSplitCommon x in Group [] [] [(commonGroup,a) | not $ null a]+++---------------------------------------------------------------------+-- ADD EXTRA PIECES+++extraFlags :: Prog_ -> Prog_+extraFlags p = p{progModes = map f $ progModes p}+    where f m = m{modeFlags_ = modeFlags_ m ++ map (\x -> def{flagFlag=x, flagExplicit=True, flagGroup=grp}) flags}+          grp = if length (progModes p) > 1 then Just commonGroup else Nothing+          flags = flagHelpFormat undefined : flagVersion vers : if progVerbosity p then flagsVerbosity verb else []+          vers x = x{cmdArgsVersion = Just $ progSumm p}+          verb v x = x{cmdArgsVerbosity = Just v}+++setHelp :: Prog_ -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)+setHelp p = mapModes0 add ""+    where+        mapModes0 f pre m = f pre $ mapModes1 f pre m+        mapModes1 f pre m = m{modeGroupModes = fmap (mapModes0 f (pre ++ head (modeNames m) ++ " ")) $ modeGroupModes m}++        add pre m = changeHelp m $ \hlp txt x -> x{cmdArgsHelp=Just $ showText txt $ msg hlp}+            where msg hlp = Line (progSumm p) : Line "" : helpText hlp (prepare m{modeNames = map (pre++) $ modeNames m})++        prepare = mapModes1 (\_ m -> m{modeGroupFlags = groupCommonHide $ modeGroupFlags m}) ""+++changeHelp :: Mode a -> (HelpFormat -> TextFormat -> a -> a) -> Mode a+changeHelp m upd = m{modeGroupFlags = fmap f $ modeGroupFlags m}+    where hlp = flagHelpFormat upd+          f flg = if flagNames hlp == flagNames flg then hlp else flg+++---------------------------------------------------------------------+-- ASSIGN NAMES++assignNames :: Prog_ -> Prog_+assignNames x = x{progModes = map f $ namesOn fromMode toMode $ progModes x}+    where+        fromMode x = Names (modeNames $ modeMode x) [asName $ ctor $ cmdArgsValue $ modeValue $ modeMode x]+        toMode xs x = x{modeMode = (modeMode x){modeNames=["["++head xs++"]" | modeDefault x] ++ xs}}++        fromFlagLong x = Names (flagNames $ flagFlag x) [asName $ fromMaybe (flagField x) (flagEnum x) | not $ flagExplicit x]+        fromFlagShort x = Names ns $ nub [take 1 s | not $ flagExplicit x, all ((/=) 1 . length) ns, s <- ns]+            where ns = flagNames $ flagFlag x+        toFlag xs x = x{flagFlag = (flagFlag x){flagNames=xs}}++        f x = x{modeFlags_ = rest ++ namesOn fromFlagShort toFlag (namesOn fromFlagLong toFlag flgs)}+            where (flgs,rest) = partition isFlag_ $ modeFlags_ x++        isFlag_ Flag_{} = True+        isFlag_ _ = False+++asName s = map (\x -> if x == '_' then '-' else toLower x) $ if last s == '_' then init s else s ++-- have are already assigned, want are a list of ones I might want+data Names = Names {have :: [String], want :: [String]}++-- error out if any name is by multiple have's, or one item would get no names+names :: [Names] -> [[String]]+names xs | not $ null bad = err "repeated names" $ unwords bad+    where bad = duplicates $ concatMap have xs++names xs | any null res = err "no available name" "?"+         | otherwise = res+    where+        bad = concatMap have xs ++ duplicates (concatMap want xs)+        res = map (\x -> have x ++ (want x \\ bad)) xs+++duplicates :: Eq a => [a] -> [a]+duplicates xs = nub $ xs \\ nub xs+++namesOn :: (a -> Names) -> ([String] -> a -> a) -> [a] -> [a]+namesOn f g xs = zipWith g (names $ map f xs) xs

@@ -0,0 +1,166 @@+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}++-- | This module takes the result of Capture, and deals with all the local+--   constraints.+module System.Console.CmdArgs.Implicit.Local(+    local, err,+    Prog_(..), progSumm, Mode_(..), Flag_(..), isFlag_+    ) where++import System.Console.CmdArgs.Implicit.Ann+import System.Console.CmdArgs.Implicit.Type+import System.Console.CmdArgs.Implicit.Read+import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Annotate+import System.Console.CmdArgs.Default++import Data.Char+import Data.Generics.Any+import Data.Maybe+++data Prog_ = Prog_+    {progModes :: [Mode_]+    ,progSummary :: Maybe String+    ,progProgram :: String+    ,progHelp :: String -- only for multiple mode programs+    ,progVerbosity :: Bool+    } deriving Show+instance Default Prog_ where+    def = Prog_ def def def def def+progSumm x = fromMaybe ("The " ++ progProgram x ++ " program") $ progSummary x++data Mode_ = Mode_+    {modeFlags_ :: [Flag_]+    ,modeMode :: Mode (CmdArgs Any)+    ,modeDefault :: Bool+    ,modeGroup :: Maybe String+    ,modeExplicit :: Bool+    } deriving Show+instance Default Mode_ where+    def = Mode_ [] m def def def+        where m = Mode (toGroup []) [] undefined Right "" [] Nothing (toGroup [])++data Flag_+    = Flag_+        {flagField :: String+        ,flagFlag :: Flag (CmdArgs Any)+        ,flagExplicit :: Bool+        ,flagGroup :: Maybe String+        ,flagEnum :: Maybe String -- if you are an enum, what is your string value+        }+    | Arg_+        {flagArg_ :: Arg (CmdArgs Any)+        ,flagArgPos :: Maybe Int+        ,flagArgOpt :: Maybe String+        }+      deriving Show+instance Default Flag_ where+    def = Flag_ "" undefined def def def++isFlag_ Flag_{} = True+isFlag_ _ = False++withMode x f = x{modeMode = f $ modeMode x}+withFlagArg x f = x{flagArg_ = f $ flagArg_ x}+withFlagFlag x f = x{flagFlag = f $ flagFlag x}++err x y = error $ "System.Console.CmdArgs.Implicit, unexpected " ++ x ++ ": " ++ y+errFlag x y = err ("flag (" ++ x ++ ")") y+++local :: Capture Ann -> Prog_+local = prog_ . defaultMissing+++---------------------------------------------------------------------+-- CAPTURE THE STRUCTURE++prog_ :: Capture Ann -> Prog_+prog_ (Ann a b) = progAnn a $ prog_ b+prog_ (Many xs) = def{progModes=map mode_ xs, progProgram=prog}+    where prog = map toLower $ typeShell $ fromCapture $ head xs+prog_ x@Ctor{} = prog_ $ Many [x]+prog_ x = err "program" $ show x+++mode_ :: Capture Ann -> Mode_+mode_ (Ann a b) = modeAnn a $ mode_ b+mode_ o@(Ctor x ys) = withMode def{modeFlags_=concat $ zipWith flag_ (fields x) ys} $ \x -> x{modeValue=embed $ fromCapture o}+mode_ x = err "mode" $ show x+++flag_ :: String -> Capture Ann -> [Flag_]+flag_ name (Ann a b) = map (flagAnn a) $ flag_ name b+flag_ name (Value x) = [def{flagField=name, flagFlag = remap embed reembed $ value_ name x}]+flag_ name x@Ctor{} = flag_ name $ Value $ fromCapture x+flag_ name (Many xs) = map (enum_ name) xs+flag_ name x = errFlag name $ show x+++enum_ :: String -> Capture Ann -> Flag_+enum_ name (Ann a b) = flagAnn a $ enum_ name b+enum_ name (Value x) = def{flagField=name, flagFlag = flagNone [] (fmap $ setField (name,x)) "", flagEnum=Just $ ctor x}+enum_ name x@Ctor{} = enum_ name $ Value $ fromCapture x+enum_ name x = errFlag name $ show x+++value_ :: String -> Any -> Flag Any+value_ name x+    | isNothing mty = errFlag name $ show x+    | isReadBool ty =+        let upd b x = setField (name,addContainer ty (getField name x) (Any b)) x+        in flagBool [] upd ""+    | otherwise =+        let upd s x = fmap (\c -> setField (name,c) x) $ reader ty s $ getField name x+        in flagReq [] upd (readHelp ty) ""+    where+        mty = toReadContainer x+        ty = fromJust mty+++---------------------------------------------------------------------+-- CAPTURE THE ANNOTATIONS++progAnn :: Ann -> Prog_ -> Prog_+progAnn (ProgSummary a) x = x{progSummary=Just a}+progAnn (ProgProgram a) x = x{progProgram=a}+progAnn ProgVerbosity x = x{progVerbosity=True}+progAnn (Help a) x | length (progModes x) > 1 = x{progHelp=a}+progAnn a x | length (progModes x) == 1 = x{progModes = map (modeAnn a) $ progModes x}+progAnn a x = err "program" $ show a+++modeAnn :: Ann -> Mode_ -> Mode_+modeAnn (Help a) x = withMode x $ \x -> x{modeHelp=a}+modeAnn (ModeHelpSuffix a) x = withMode x $ \x -> x{modeHelpSuffix=a}+modeAnn ModeDefault x = x{modeDefault=True}+modeAnn (GroupName a) x = x{modeGroup=Just a}+modeAnn Explicit x = x{modeExplicit=True}+modeAnn a x = err "mode" $ show a+++flagAnn :: Ann -> Flag_ -> Flag_+flagAnn (FlagType a) x@Arg_{} = withFlagArg x $ \x -> x{argType=a}+flagAnn (FlagType a) x@Flag_{} = withFlagFlag x $ \x -> x{flagType=a}+flagAnn (Help a) x@Flag_{} = withFlagFlag x $ \x -> x{flagHelp=a}+flagAnn (FlagArgPos a) x = toArg x $ Just a+flagAnn FlagArgs x = toArg x Nothing+flagAnn Explicit x@Flag_{} = x{flagExplicit=True}+flagAnn (FlagOptional a) x@Flag_{flagEnum=Nothing,flagFlag=Flag{flagInfo=FlagReq}} = withFlagFlag x $ \x -> x{flagInfo=FlagOpt a}+flagAnn (FlagOptional a) x@Arg_{} = x{flagArgOpt=Just a}+flagAnn (Name a) x@Flag_{} = withFlagFlag x $ \x -> x{flagNames = a : flagNames x}+flagAnn (GroupName a) x@Flag_{} = x{flagGroup=Just a}+flagAnn a x = errFlag (head $ words $ show x) $ show a++toArg :: Flag_ -> Maybe Int -> Flag_+toArg (Flag_ fld x False Nothing Nothing) pos+    | null (flagNames x), null (flagHelp x), Just y <- opt $ flagInfo x+    = Arg_ (Arg (flagValue x) (flagType x)) pos y+    where+        opt FlagReq = Just Nothing+        opt (FlagOpt x) = Just (Just x)+        opt (FlagOptRare x) = Just Nothing+        opt _ = Nothing+toArg a _ = errFlag "args/argPos" $ show a

@@ -1,176 +0,0 @@-{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}---- | This module takes the result of Structure, and traslates it to---   the CmdArgs.Explicit format.-module System.Console.CmdArgs.Implicit.Step1(step1, Prog1(..), Mode1(..), Flag1(..)) where--import System.Console.CmdArgs.Implicit.Ann-import Data.Generics.Any-import System.Console.CmdArgs.Implicit.Capture--import Data.Char-import Data.List---data Prog1 = Prog1 [Ann] [Mode1] deriving Show-data Mode1 = Mode1 [Ann] Any [Flag1] deriving Show-data Flag1 = Flag1 [Ann] String Any deriving Show---step1 :: Capture -> Prog1-step1 = expand . groupnames . inherit . flatten---err x = error $ "CmdArgs.Implicit.Step1: " ++ x---mapMode :: (Mode1 -> Mode1) -> Prog1 -> Prog1-mapMode f (Prog1 a b) = Prog1 a $ map f b--------------------------------------------------------------------------- EXPAND FLAGS--- Add FlagName properties where you can---- For every flag/mode, assign it a name based on the type information, unless it has explicit--- For every flag, assign it a short name if it doesn't have one and it would be unambiguous, and no explicit--- Remove all explicit annotations-expand :: Prog1 -> Prog1-expand = mapMode (removeExplicit . assignShort . assignLong)---removeExplicit (Mode1 a b c) = Mode1 (del a) b $ map f c-    where f (Flag1 a b c) = Flag1 (del a) b c-          del = filter (/= Explicit)---assignShort (Mode1 a b c) = Mode1 a b [Flag1 ((s \\ dupe) ++ x) y z | (s,Flag1 x y z) <- zip poss c]-    where seen = [x | Flag1 a _ _ <- c, Name [x] <- a]-          dupe = concat poss \\ nub (concat poss)-          poss = map f c-          f (Flag1 a b c) = [Name [x] | Explicit `notElem` a, null [() | Name [_] <- a]-                                       , x <- take 1 [head x | Name x <- a], x `notElem` seen]---assignLong (Mode1 a b c) = Mode1 (add (ctor b) a) b $ map f c-    where f (Flag1 a b c) = Flag1 (add newname a) b c-               where newname = if FlagEnum `elem` a then ctor c else b-          add s xs = [Name ss | all g xs, Name ss `notElem` xs] ++ xs-               where ss = map (\x -> if x == '_' then '-' else toLower x) $ if last s == '_' then init s else s--          g Explicit = False-          g FlagArgs = False-          g FlagArgPos{} = False-          g _ = True--------------------------------------------------------------------------- GROUP NAMES--- Make sure every mode/flag has a GroupName annotation--groupnames :: Prog1 -> Prog1-groupnames (Prog1 a b) = Prog1 a $ f onmode "" [Mode1 c d $ f onflag "" e | Mode1 c d e <- b]-    where-        onmode (Mode1 a b c) = (a, \a -> Mode1 a b c)-        onflag (Flag1 a b c) = (a, \a -> Flag1 a b c)--        f on name [] = []-        f on name (x:xs) = case [y | GroupName y <- c] of-            [] -> g (GroupName name:c) : f on name xs-            ys -> x : f on (last ys) xs-            where (c,g) = on x--------------------------------------------------------------------------- INHERIT--- Deal with FlagInherit--inherit :: Prog1 -> Prog1-inherit (Prog1 a b) = Prog1 a $ f ask0 b-    where-        ask0 s = err $ "Field missing and not specified previously: " ++ show s--        f ask (x:xs) = x2 : f (\s -> let c = [b | b@(Flag1 _ a _) <- cs, a == s] in if null c then ask s else c) xs-            where x2@(Mode1 _ _ cs) = inheritMode ask x-        f ask [] = []---inheritMode :: (String -> [Flag1]) -> Mode1 -> Mode1-inheritMode ask (Mode1 a b c) = Mode1 a (foldr ($) b upd) (concat c2)-    where (c2,upd) = unzip $ map (inheritFlag ask) c---inheritFlag :: (String -> [Flag1]) -> Flag1 -> ([Flag1], Any -> Any)-inheritFlag ask (Flag1 a b c)-    | FlagInherit `notElem` a = ([Flag1 a b c], id)-    | or [typeOf c /= typeOf c2 | Flag1 _ _ c2 <- ys] = err $ "Field missing and previous instance has a different type:" ++ show b-    | Flag1 a2 b2 c2 : _ <- ys = (ys, setField (b2,c2))-    where ys = ask b-------------------------------------------------------------------------- FLATTEN--- Separate the data in to Prog/Mode/Flag--flatten :: Capture -> Prog1-flatten = moveAnn . flattenProg----- Move annotations from Prog to Mode if appropriate--- 'Help' can be at the program level for multi-mode programs-moveAnn :: Prog1 -> Prog1-moveAnn (Prog1 as ms) = Prog1 prog [Mode1 (mode++a) b c | Mode1 a b c <- ms]-    where (prog,mode) = partition (\x -> case x of Help{} -> length ms > 1; _ -> isProgAnn x) as--isProgAnn ProgSummary{} = True-isProgAnn ProgProgram{} = True-isProgAnn ProgVerbosity{} = True-isProgAnn _ = False---flattenProg :: Capture -> Prog1-flattenProg (Ann a b) = let Prog1 x y = flattenProg b in Prog1 (x++[a]) y-flattenProg (Many xs) = Prog1 [] $ map flattenMode xs-flattenProg x@Ctor{} = Prog1 [] [flattenMode x]-flattenProg x = err $ "Unexpected in a program: " ++ show x---flattenMode :: Capture -> Mode1-flattenMode (Ann a b) = let Mode1 x y z = flattenMode b in Mode1 (x++[a]) y z-flattenMode (Ctor x ys) = Mode1 [] x [Flag1 a n b | (y,n) <- zip ys $ fields x, Flag1 a _ b <- flattenFlag y]-flattenMode x = err $ "Unexpected in a mode: " ++ show x---flattenFlag :: Capture -> [Flag1]-flattenFlag (Ann a b) = [Flag1 (x++[a]) y z | Flag1 x y z <- flattenFlag b]-flattenFlag (Value x) = [Flag1 [] "" x]-flattenFlag (Missing x) = [Flag1 [FlagInherit] "" x]-flattenFlag x@Ctor{} = [Flag1 [] "" $ flattenValue x]-flattenFlag (Many xs) = concatMap flattenFlag $ map (Ann FlagEnum) xs-flattenFlag x = err $ "Unexpected in a flag: " ++ show x---flattenValue :: Capture -> Any-flattenValue (Ctor x _) = x-flattenValue (Value x) = x-flattenValue x = err $ "Unexpected in a value: " ++ show x---{--*** Exception:--Ann (ProgSummary "HLint v1.6.5, (C) Neil Mitchell 2006-2009")-Ann (ModeHelpSuffix ["To check all Haskell files in 'src' and generate a report type:","  hlint src --report"])-Ann (Text "Suggest improvements to Haskell source code")-Ann (ProgProgram "hlint")--(Ctor HLint-    [Ann (Text "Generate a report in HTML") (Ann (FldTyp "FILE") (Ann (FldEmpty "report.html") (Ctor [] [])))-    ,Ann (Text "Hint/ignore file to use") (Ann (FldTyp "FILE") (Ctor [] []))-    ,Ann (Text "Color the output (requires ANSI terminal)") (Ann (FldFlag "colour") (Ann (FldFlag "c") (Ctor False [])))-    ,Ann (Text "Ignore a particular hint") (Ann (FldTyp "MESSAGE") (Ctor [] []))-    ,Ann (Text "Show all ignored ideas") (Ctor False []),Ann (Text "Run in test mode") (Ctor False [])-    ,Ann (Text "CPP #define") (Ann (FldTyp "NAME[=VALUE]") (Ctor [] []))-    ,Ann (Text "CPP include path") (Ann (FldTyp "DIR") (Ctor [] []))-    ,Ann (FldTyp "FILE/DIR") (Ann FldArgs (Ctor [] []))]))))--}

@@ -1,128 +0,0 @@-{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}---- | This module takes the result of Capture, and forms the structure of---   the arguments. This module supplies the most direct translation of---   the annotations.-module System.Console.CmdArgs.Implicit.Step2(-    step2,-    Prog2(..), Mode2(..), Flag2(..), Flag2Type(..), Arg2(..)-    ) where--import System.Console.CmdArgs.Implicit.Ann-import System.Console.CmdArgs.Implicit.Read-import System.Console.CmdArgs.Implicit.Step1-import System.Console.CmdArgs.Explicit--import Data.Char-import Data.Generics.Any-import Data.List-import Data.Maybe---data Prog2 a = Prog2-    {prog2Summary :: String-    ,prog2Name :: String-    ,prog2Help :: String-    ,prog2Verbosity :: Bool-    ,prog2ModeDefault :: Maybe Int -- index in to prog2Modes-    ,prog2Modes :: [Mode2 a]-    }--data Mode2 a = Mode2-    {mode2Names :: [Name]-    ,mode2Group :: String-    ,mode2Value :: a-    ,mode2Help :: Help-    ,mode2Suffix :: [String]-    ,mode2Flags :: [Flag2 a]-    ,mode2Args :: [Arg2 a]-    }--data Flag2 a = Flag2-    {flag2Names :: [Name]-    ,flag2Group :: String-    ,flag2Upd :: Flag2Type a-    ,flag2Opt :: Maybe String-    ,flag2FlagHelp :: FlagHelp-    ,flag2Help :: Help-    }--data Flag2Type a-    = Flag2String {fromFlag2String :: String -> a -> Either String a}-    | Flag2Bool (Bool -> a -> a)-    | Flag2Value (a -> a)--data Arg2 a = Arg2-    {arg2FlagHelp :: FlagHelp-    ,arg2Upd :: String -> a -> Either String a-    ,arg2Pos :: Maybe Int-    ,arg2Opt :: Maybe String-    }---step2 :: Prog1 -> Prog2 Any-step2 = transProg---isArg FlagArgs = True-isArg FlagArgPos{} = True-isArg _ = False--------------------------------------------------------------------------- TRANSLATE--- Translate in to the Mode domain--transProg :: Prog1 -> Prog2 Any-transProg (Prog1 ann xs) = Prog2 summary program hlp verb defMode (map transMode xs)-    where-        summary = let x = concat [x | ProgSummary x <- ann] in if null x then "The " ++ defProg ++ " program" else x-        hlp = concat [x | Help x <- ann]-        defMode = flip findIndex xs $ \(Mode1 an _ _) -> length xs /= 1 && ModeDefault `elem` an-        verb = ProgVerbosity `elem` ann-        program = last $ defProg : [x | ProgProgram x <- ann]-        defProg = let Mode1 _ x _ = head xs in map toLower $ typeShell x---transMode :: Mode1 -> Mode2 Any-transMode (Mode1 an c xs) = Mode2-    [x | Name x <- an]-    (last $ "" : [x | GroupName x <- an])-    c-    (concat [x | Help x <- an])-    (concat [x | ModeHelpSuffix x <- an])-    (map transFlag rest)-    (map transArg args)-    where (args,rest) = partition (ann isArg) xs-          ann f (Flag1 x _ _) = any f x---transFlag :: Flag1 -> Flag2 Any-transFlag flag@(Flag1 ann fld val)-    | Just (flaghelpdef,upd) <- transFlagType flag =-        Flag2 names grp upd opt (if null flaghelp then flaghelpdef else flaghelp) help-    | otherwise = error $ "Don't know how to deal with field type, " ++ fld ++ " :: " ++ show val-    where-        opt = let a = [x | FlagOptional x <- ann] in if null a then Nothing else Just $ concat a-        grp = last $ "" : [x | GroupName x <- ann]-        help = concat [x | Help x <- ann] ++ concat [" (default=" ++ x ++ ")" | Just x <- [opt], x /= ""]-        names = [x | Name x <- ann]-        flaghelp = concat [x | FlagType x <- ann]---transFlagType :: Flag1 -> Maybe (String,Flag2Type Any)-transFlagType (Flag1 ann fld val)-    | FlagEnum `elem` ann = Just $ (,) "" $ Flag2Value $ \x -> setField (fld,val) x-    | isNothing mty = Nothing-    | isReadBool ty = f $ Flag2Bool $ \b x -> setField (fld,addContainer ty (getField fld x) (Any b)) x-    | otherwise = f $ Flag2String $ \s x -> fmap (\c -> setField (fld,c) x) $ reader ty s $ getField fld x-    where-        mty = toReadContainer val-        ty = fromJust mty-        f x = Just (readHelp ty, x)---transArg :: Flag1 -> Arg2 Any-transArg x@(Flag1 ann _ _) = Arg2 (flag2FlagHelp y) (fromFlag2String $ flag2Upd y) pos (flag2Opt y)-    where y = transFlag x-          pos = listToMaybe [i | FlagArgPos i <- ann]

@@ -1,189 +0,0 @@-{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards, DeriveDataTypeable #-}---- | This module takes the result of Structure, and traslates it to---   the CmdArgs.Explicit format.-module System.Console.CmdArgs.Implicit.Step3(-    step3,-    -- cmdArgs_privateArgsSeen is exported, otherwise Haddock-    -- gets confused when using RecordWildCards-    CmdArgs(..), cmdArgsHasValue-    ) where--import System.Console.CmdArgs.Implicit.Step2-import System.Console.CmdArgs.Explicit-import System.Console.CmdArgs.Verbosity-import System.Console.CmdArgs.Text--import Control.Arrow-import Data.Data-import Data.Maybe-import Data.Monoid-import Data.List-import Data.Function----- | A structure to store the additional data relating to @--help@,---   @--version@, @--quiet@ and @--verbose@.-data CmdArgs a = CmdArgs-    {cmdArgsValue :: a -- ^ The underlying value being wrapped.-    ,cmdArgsHelp :: Maybe String -- ^ @Just@ if @--help@ is given, then gives the help message for display.-    ,cmdArgsVersion :: Maybe String -- ^ @Just@ if @--verion@ is given, then gives the version message for display.-    ,cmdArgsVerbosity :: Maybe Verbosity -- ^ @Just@ if @--quiet@ or @--verbose@ is given, then gives the verbosity to use.-    ,cmdArgsPrivate :: CmdArgsPrivate -- ^ Private: Only exported due to Haddock limitations.-    }-    deriving (Show,Data,Typeable)--instance Functor CmdArgs where-    fmap f x = x{cmdArgsValue = f $ cmdArgsValue x}--cmdArgsHasValue :: CmdArgs a -> Bool-cmdArgsHasValue x = isNothing (cmdArgsHelp x) && isNothing (cmdArgsVersion x)--data CmdArgsPrivate = CmdArgsPrivate-    Int -- ^ The number of arguments that have been seen-    deriving (Data,Typeable)--instance Show CmdArgsPrivate where show _ = "CmdArgsPrivate"--incArgsSeen x = x{cmdArgsPrivate = CmdArgsPrivate $ getArgsSeen x + 1}-getArgsSeen CmdArgs{cmdArgsPrivate = CmdArgsPrivate i} = i---step3 :: Prog2 a -> Mode (CmdArgs a)-step3 p = common p $ transProg $ liftProg p--------------------------------------------------------------------------- COMMON--- Add common flags (--help/--version etc)--common :: Prog2 a -> Mode (CmdArgs a) -> Mode (CmdArgs a)-common p m-    | null $ modeModes m = addNormal m $ commonFlags p $ addNormal m-    | otherwise = addCommon m2 $ commonFlags p $ addCommon m2-    where-        add m xs = m{modeGroupFlags = xs `mappend` modeGroupFlags m}-        addNormal m xs = add m $ toGroup xs-        addCommon m xs = add m $ Group [] [] [("Common flags",xs)]-        addHidden m xs = add m $ Group [] xs []--        m2 = m{modeGroupModes = fmap f $ modeGroupModes m}-        f m = addHidden m $ commonFlags p $ addCommon $ m{modeNames = map ((prog2Name p ++ " ") ++) $ modeNames m}----- add common flags to a mode-commonFlags :: Prog2 a -> ([Flag (CmdArgs a)] -> Mode (CmdArgs a)) -> [Flag (CmdArgs a)]-commonFlags Prog2{..} add = flags-    where-        help hlp txt = showText txt $ Line prog2Summary : Line "" : helpText hlp (add flags)-        flags = -            [flagHelpFormat $ \hlp txt x -> x{cmdArgsHelp = Just $ help hlp txt}-            ,flagVersion $ \x -> x{cmdArgsVersion = Just prog2Summary}] ++-            if not prog2Verbosity then [] else flagsVerbosity $ \v x -> x{cmdArgsVerbosity=Just v}--------------------------------------------------------------------------- TRANSLATE--- Translate in to the CmdArgs.Explicit domain--transProg :: Prog2 (CmdArgs a) -> Mode (CmdArgs a)-transProg p = res{modeNames = [prog2Name p]}-    where-        res = if length ys == 1 then snd $ head ys else defMode{modeGroupModes = toGroups ys, modeHelp = prog2Help p}-        defMode = maybe zeroMode (silentMode . snd . (ys!!)) $ prog2ModeDefault p-        silentMode m = m{modeGroupFlags=Group [] (modeFlags m) [], modeArgs=fmap (\x -> x{argType=""}) (modeArgs m)}-        ys = zip (map mode2Group $ prog2Modes p) $-                 zipWith transMode (map ((==) (prog2ModeDefault p) . Just) [0..]) $ prog2Modes p--        zeroMode = Mode (toGroup []) [] (embed $ error msg) chk "" [] Nothing $ toGroup []-            where msg = "System.Console.CmdArgs.Implicit: No default mode given (see cmdArgsHelp/cmdArgsVersion)"-                  chk x = if cmdArgsHasValue x then Left "No mode given and no default mode" else Right x---transMode :: Bool -> Mode2 (CmdArgs a) -> Mode (CmdArgs a)-transMode auto Mode2{..} = transArgs mode2Args $ Mode-    (toGroup [])-    (["[" ++ head mode2Names ++ "]" | auto] ++ mode2Names)-    mode2Value-    Right-    mode2Help-    mode2Suffix-    Nothing-    (toGroups $ map (flag2Group &&& transFlag) mode2Flags)---toGroups :: [(String,a)] -> Group a-toGroups xs = Group (f "") [] (map (id &&& f) names)-    where names = filter (not . null) $ nub $ map fst xs-          f x = map snd $ filter ((==) x . fst) xs---transFlag :: Flag2 (CmdArgs a) -> Flag (CmdArgs a)-transFlag Flag2{..} = case flag2Upd of-    Flag2String upd -> (maybe flagReq flagOpt flag2Opt) flag2Names upd flag2FlagHelp flag2Help-    Flag2Bool upd -> flagBool flag2Names upd flag2Help-    Flag2Value upd -> flagNone flag2Names upd flag2Help---transArgs :: [Arg2 (CmdArgs a)] -> Mode (CmdArgs a) -> Mode (CmdArgs a)-transArgs [] x = x-transArgs xs x = x{modeCheck=chk, modeArgs = Just $ flagArg upd hlp}-    where-        (ord,rep) = orderArgs xs-        mn = length $ dropWhile (isJust . arg2Opt) $ reverse ord--        chk v | not $ cmdArgsHasValue v = Right v-              | n < mn = Left $ "Requires at least " ++ show mn ++ " arguments, got " ++ show n-              | otherwise = foldl f (addOptArgs n v) (drop n ord)-            where n = getArgsSeen v-                  f (Right v) arg = arg2Upd arg (fromJust $ arg2Opt arg) v-                  f x _ = x--        -- if we have repeating args which is also opt, translate that here-        addOptArgs n v-            | Just x <- rep, Just o <- arg2Opt x, Just n <= findIndex (isNothing . arg2Pos) (ord ++ [x]) = arg2Upd x o v-            | otherwise = Right v--        hlp = unwords $ a ++ map (\x -> "["++x++"]") b-            where (a,b) = splitAt mn $ map arg2FlagHelp $ ord ++ maybeToList rep--        upd s v | n < length ord = arg2Upd (ord !! n) s v2-                | Just x <- rep = arg2Upd x s v2-                | otherwise = Left $ "expected at most " ++ show (length ord)-            where n = getArgsSeen v-                  v2 = incArgsSeen v----- return the arguments in order, plus those at the end-orderArgs :: [Arg2 a] -> ([Arg2 a], Maybe (Arg2 a))-orderArgs args = (f 0 ord, listToMaybe rep)-    where-        (rep,ord) = span (isNothing . arg2Pos) $ sortBy (compare `on` arg2Pos) args-        f i [] = []-        f i (x:xs) = case fromJust (arg2Pos x) `compare` i of-            LT -> f i xs-            EQ -> x : f (i+1) xs-            GT -> take 1 rep ++ f (i+1) (x:xs)--------------------------------------------------------------------------- LIFT--- Add the CmdArgs structure--embed x = CmdArgs x Nothing Nothing Nothing $ CmdArgsPrivate 0-proj x = (cmdArgsValue x, \y -> x{cmdArgsValue=y})--liftProg :: Prog2 a -> Prog2 (CmdArgs a)-liftProg x = x{prog2Modes = map liftMode $ prog2Modes x}--liftMode :: Mode2 a -> Mode2 (CmdArgs a)-liftMode x = x-    {mode2Value = embed $ mode2Value x-    ,mode2Flags = map liftFlag $ mode2Flags x-    ,mode2Args = map liftArg $ mode2Args x}--liftFlag x = x{flag2Upd = liftType $ flag2Upd x}-liftArg x = x{arg2Upd = fromFlag2String $ liftType $ Flag2String $ arg2Upd x}-liftType (Flag2String upd) = Flag2String $ \s v -> let (a,b) = proj v in fmap b $ upd s a-liftType (Flag2Bool upd) = Flag2Bool $ \s v -> let (a,b) = proj v in b $ upd s a-liftType (Flag2Value upd) = Flag2Value $ \v -> let (a,b) = proj v in b $ upd a

@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | The underlying CmdArgs type.+module System.Console.CmdArgs.Implicit.Type(+    -- cmdArgs_privateArgsSeen is exported, otherwise Haddock+    -- gets confused when using RecordWildCards+    CmdArgs(..), CmdArgsPrivate(..), cmdArgsHasValue, embed, reembed+    ) where++import System.Console.CmdArgs.Verbosity++import Data.Data+import Data.Maybe+++-- | A structure to store the additional data relating to @--help@,+--   @--version@, @--quiet@ and @--verbose@.+data CmdArgs a = CmdArgs+    {cmdArgsValue :: a -- ^ The underlying value being wrapped.+    ,cmdArgsHelp :: Maybe String -- ^ @Just@ if @--help@ is given, then gives the help message for display.+    ,cmdArgsVersion :: Maybe String -- ^ @Just@ if @--verion@ is given, then gives the version message for display.+    ,cmdArgsVerbosity :: Maybe Verbosity -- ^ @Just@ if @--quiet@ or @--verbose@ is given, then gives the verbosity to use.+    ,cmdArgsPrivate :: CmdArgsPrivate -- ^ Private: Only exported due to Haddock limitations.+    }+    deriving (Show,Data,Typeable)++cmdArgsHasValue :: CmdArgs a -> Bool+cmdArgsHasValue x = isNothing (cmdArgsHelp x) && isNothing (cmdArgsVersion x)++data CmdArgsPrivate = CmdArgsPrivate+    Int -- ^ The number of arguments that have been seen+    deriving (Data,Typeable)++instance Show CmdArgsPrivate where show _ = "CmdArgsPrivate"++instance Functor CmdArgs where+    fmap f x = x{cmdArgsValue = f $ cmdArgsValue x}+++embed :: a -> CmdArgs a+embed x = CmdArgs x Nothing Nothing Nothing (CmdArgsPrivate 0)++reembed :: CmdArgs a -> (a, a -> CmdArgs a)+reembed x = (cmdArgsValue x, \y -> x{cmdArgsValue=y})+

@@ -1,4 +1,3 @@-{-# LANGUAGE PatternGuards #-} {-|     This module describes the attributes that can be specified on flags and modes. @@ -6,7 +5,6 @@      > data Sample = Sample {hello :: String} -}- module System.Console.CmdArgs.Implicit.UI where  import System.Console.CmdArgs.Implicit.Ann@@ -148,7 +146,7 @@ --   A field should not have any flag names guessed for it. --   All flag names must be specified by 'flag'. ----- > {hello = def &= explicit &= flag "foo"}+-- > {hello = def &= explicit &= name "foo"} -- >   --foo=VALUE explicit :: Ann explicit = Explicit

@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, NamedFieldPuns #-}+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-} module System.Console.CmdArgs.Test.Implicit.HLint where import System.Console.CmdArgs import System.Console.CmdArgs.Test.Implicit.Util@@ -42,20 +43,22 @@     } &=     verbosity &=     help "Suggest improvements to Haskell source code" &=-    summary "HLint v0.0.0, (C) Neil Mitchell 2006-2010" &=+    summary "HLint v0.0.0, (C) Neil Mitchell" &=     details ["Hlint gives hints on how to improve Haskell code",""             ,"To check all Haskell files in 'src' and generate a report type:","  hlint src --report"]  mode = cmdArgsMode hlint  test = do-    let Tester{(===),fails,isVerbosity} = tester "HLint" mode+    let Tester{..} = tester "HLint" mode     [] === hlint     fails ["-ch"]     isVerbosity ["--color","--quiet"] Quiet     isVerbosity ["--color","--verbose"] Loud     isVerbosity ["--color","--quiet","--verbose"] Loud     isVerbosity [] Normal+    isHelp ["-?"] ["HLint v0.0.0, (C) Neil Mitchell"]+    isHelp ["--help"] ["  hlint src --report"]     ["--colo"] === hlint{color=True}     ["--colour","--colour=false"] === hlint     ["--colour=true"] === hlint{color=True}

@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, NamedFieldPuns #-}-{-# OPTIONS_GHC -fno-cse #-}+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-unused-binds #-} module System.Console.CmdArgs.Test.Implicit.Maker where import System.Console.CmdArgs import System.Console.CmdArgs.Test.Implicit.Util@@ -33,9 +33,34 @@  mode = cmdArgsMode $ modes [build,wipe,test_] &= help "Build helper program" &= program "maker" &= summary "Maker v1.0" +mode_ = cmdArgsMode_ $ modes_ [build,wipe,test_] += help "Build helper program" += program "maker" += summary "Maker v1.0"+  where+    threads_ = threads := def += help "Number of threads to use" += name "j" += typ "NUM"++    wipe = record Wipe{} [] += help "Clean all build objects"++    test_ = record Test{}+        [threads_+        ,extra := def += typ "ANY" += args+        ] += help "Run the test suite"++    build = record Build{}+        [threads_ +        ,enum_ method+            [atom Release += help "Release build"+            ,atom Debug += help "Debug build"+            ,atom Profile += help "Profile build"]+        ,files := def += args+        ] += help "Build the project" += auto++ test = do-    let Tester{(===),fails} = tester "Maker" mode+    let Tester{..} = testers "Maker" [mode,mode_]     [] === build+    isHelp ["-?=one"] ["Common flags:"]+    isHelpNot ["-?=one"] ["  -d --debug  Debug build"]+    isHelp ["-?=all"] ["maker [build] [OPTIONS] [ITEM]"]+    isHelp ["build","-?=one"] ["maker [build] [OPTIONS] [ITEM]"]     ["build","foo","--profile"] === build{files=["foo"],method=Profile}     ["foo","--profile"] === build{files=["foo"],method=Profile}     ["foo","--profile","--release"] === build{files=["foo"],method=Release}@@ -49,4 +74,10 @@     ["test","foo"] === test_{extra=["foo"]}     ["test","foo","-j3"] === test_{extra=["foo"],threads=3}     fails ["test","foo","-baz","-j3","--what=1"]-+    ["test","foo","--","-baz","-j3","--what=1"] === test_{extra=["foo","-baz","-j3","--what=1"]}+    ["test","--","foo","-baz","-j3","--what=1"] === test_{extra=["foo","-baz","-j3","--what=1"]}+    ["--"] === build+    ["test","--"] === test_+    ["test","-j3","--","foo","-baz","-j3","--what=1"] === test_{extra=["foo","-baz","-j3","--what=1"],threads=3}+    ["test","-"] === test_{extra=["-"]}+    ["build","-"] === build{files=["-"]}

@@ -7,6 +7,7 @@ import System.Console.CmdArgs.Explicit(modeHelp) import System.Console.CmdArgs.Test.Implicit.Util + test = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> test9 >> test10 >> test11 demos = zipWith f [1..]         [toDemo mode1, toDemo mode2, toDemo mode3, toDemo mode4, toDemo mode5, toDemo mode6@@ -41,6 +42,7 @@     ["--maybebool=off"] === def1{maybeBool=Just False}     ["--listbool","--listbool=true","--listbool=false"] === def1{listBool=[True,True,False]}     fails ["--listbool=fred"]+    invalid $ \_ -> def1{listBool = def &= opt "yes"}   -- from bug #230@@ -140,9 +142,12 @@              deriving (Eq,Show,Data,Typeable)  mode8 = cmdArgsMode $ modes [Test8 1 (2 &= groupname "More flags") 3 &= groupname "Mode1", Test81, Test82 &= groupname "Mode2"]+mode8_ = cmdArgsMode_ $ modes_ [record Test8{} [atom (1::Int), atom (2::Int) += groupname "More flags", atom (3::Int)] += groupname "Mode1"+                               ,record Test81{} []+                               ,record Test82{} [] += groupname "Mode2"]  test8 = do-    let Tester{..} = tester "Test8" mode8+    let Tester{..} = testers "Test8" [mode8,mode8_]     isHelp ["-?"] ["Flags:","  --test8a=INT","More flags:","  --test8b=INT"]     fails []     ["test8","--test8a=18"] === Test8 18 2 3@@ -153,10 +158,11 @@            | Test92 {foo :: XYZ}              deriving (Eq,Show,Data,Typeable) -mode9 = cmdArgsMode $ modes [Test91 {foo = enum [X &= help "pick X (default)", Y &= help "pick Y"] &= opt "Y"} &= auto, Test92{}]+mode9 = cmdArgsMode $ modes [Test91 {foo = enum [X &= help "pick X (default)", Y &= help "pick Y"]} &= auto, Test92{}]+mode9_ = cmdArgsMode_ $ modes_ [record Test91{} [enum_ foo [atom X += help "pick X (default)", atom Y += help "pick Y"]] += auto, record Test92{} []]  test9 = do-    let Tester{..} = tester "Test9" mode9+    let Tester{..} = testers "Test9" [mode9,mode9_]     [] === Test91 X     ["test91","-x"] === Test91 X     ["test91","-y"] === Test91 Y@@ -164,6 +170,7 @@     ["test92","-x"] === Test92 X     ["test92","-y"] === Test92 Y     ["test92"] === Test92 X+    invalid $ \_ -> modes [Test91 {foo = enum [X &= help "pick X (default)"] &= opt "X"}]  -- share common fields in the help message data Test10 = Test101 {food :: Int}@@ -174,11 +181,10 @@  test10 = do     let Tester{..} = tester "Test10" mode10-    -- FIXME: isHelp ["-?=one"] ["  -f --food=INT"]+    isHelp ["-?=one"] ["  -f --food=INT"]     isHelpNot ["-?=one"] ["  -b --bard=INT"]  -- test for GHC over-optimising- data Test11 = Test11A {test111 :: String}             | Test11B {test111 :: String}               deriving (Eq,Show,Data,Typeable)@@ -187,8 +193,12 @@ test11B = Test11B { test111 = def &= argPos 0 } mode11 = cmdArgsMode $ modes [test11A, test11B] +mode11_ = cmdArgsMode_ $ modes_+    [record Test11A{} [test111 := def += argPos 0]+    ,record Test11B{} [test111 := def += argPos 0]]+ test11 = do-    let Tester{..} = tester "Test11" mode11+    let Tester{..} = testers "Test11" [mode11,mode11_]     fails []     ["test11a","test"] === Test11A "test"     ["test11b","test"] === Test11B "test"

@@ -5,6 +5,7 @@ import System.Console.CmdArgs.Implicit import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Test.Util+import Control.Exception import Data.Char import Data.List import Data.Maybe@@ -13,6 +14,14 @@ toDemo = newDemo $ \x -> cmdArgsApply x >>= print  +invalid :: Data a => (() -> a) -> IO ()+invalid a = do+    res <- try $ evaluate $ length $ show $ cmdArgsMode $ a ()+    case res of+        Left (ErrorCall _) -> success+        Right _ -> failure "Expected exception" []++ data Tester a = Tester     {(===) :: [String] -> a -> IO ()     ,fails :: [String] -> IO ()@@ -21,6 +30,14 @@     ,isVersion :: [String] -> String -> IO ()     ,isVerbosity :: [String] -> Verbosity -> IO ()     }++testers :: (Show a, Eq a) => String -> [Mode (CmdArgs a)] -> Tester a+testers name = foldr1 f . map (tester name)+    where+        f (Tester x1 x2 x3 x4 x5 x6) (Tester y1 y2 y3 y4 y5 y6) =+            Tester (f2 x1 y1) (f1 x2 y2) (f2 x3 y3) (f2 x4 y4) (f2 x5 y5) (f2 x6 y6)+        f1 x y a = x a >> y a+        f2 x y a b = x a b >> y a b   tester :: (Show a, Eq a) => String -> Mode (CmdArgs a) -> Tester a

@@ -1,4 +1,3 @@-{-# LANGUAGE PatternGuards #-}  -- | A module to represent text with very basic formatting. Values are of --   type ['Text'] and shown with 'showText'.

@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               cmdargs-version:            0.3+version:            0.4 license:            BSD3 license-file:       LICENSE category:           Console@@ -42,6 +42,7 @@      exposed-modules:         System.Console.CmdArgs+        System.Console.CmdArgs.Annotate         System.Console.CmdArgs.Default         System.Console.CmdArgs.Explicit         System.Console.CmdArgs.GetOpt@@ -56,11 +57,10 @@         System.Console.CmdArgs.Explicit.Process         System.Console.CmdArgs.Explicit.Type         System.Console.CmdArgs.Implicit.Ann-        System.Console.CmdArgs.Implicit.Capture         System.Console.CmdArgs.Implicit.Read-        System.Console.CmdArgs.Implicit.Step1-        System.Console.CmdArgs.Implicit.Step2-        System.Console.CmdArgs.Implicit.Step3+        System.Console.CmdArgs.Implicit.Local+        System.Console.CmdArgs.Implicit.Global+        System.Console.CmdArgs.Implicit.Type         System.Console.CmdArgs.Implicit.UI  executable cmdargs