Render short option with arg. (#9043)

Author: philderbeast

Cabal/src/Distribution/GetOpt.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
------------------------------------------------------------------------------
 {-# LANGUAGE TupleSections #-}
 
+-----------------------------------------------------------------------------
+
 -- |
 -- Module      :  Distribution.GetOpt
 -- Copyright   :  (c) Sven Panne 2002-2005
@@ -67,12 +68,12 @@ data ArgDescr a
   | -- |   option requires argument
     ReqArg (String -> Either String a) String
   | -- |   optional argument
-    OptArg (Maybe String -> Either String a) String
+    OptArg String (Maybe String -> Either String a) String
 
 instance Functor ArgDescr where
   fmap f (NoArg a) = NoArg (f a)
   fmap f (ReqArg g s) = ReqArg (fmap f . g) s
-  fmap f (OptArg g s) = OptArg (fmap f . g) s
+  fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s
 
 data OptKind a -- kind of cmd line arg (internal use only):
   = Opt a --    an option
@@ -130,17 +131,41 @@ zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as
 zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs
 zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs
 
+-- | Pretty printing of short options.
+-- * With required arguments can be given as:
+--    @-w PATH or -wPATH (but not -w=PATH)@
+--   This is dislayed as:
+--    @-w PATH or -wPATH@
+-- * With optional but default arguments can be given as:
+--    @-j or -jNUM (but not -j=NUM or -j NUM)@
+--   This is dislayed as:
+--    @-j[NUM]@
 fmtShort :: ArgDescr a -> Char -> String
 fmtShort (NoArg _) so = "-" ++ [so]
-fmtShort (ReqArg _ _) so = "-" ++ [so]
-fmtShort (OptArg _ _) so = "-" ++ [so]
-
--- unlike upstream GetOpt we omit the arg name for short options
-
+fmtShort (ReqArg _ ad) so =
+  let opt = "-" ++ [so]
+   in opt ++ " " ++ ad ++ " or " ++ opt ++ ad
+fmtShort (OptArg _ _ ad) so =
+  let opt = "-" ++ [so]
+   in opt ++ "[" ++ ad ++ "]"
+
+-- | Pretty printing of long options.
+-- * With required arguments can be given as:
+--    @--with-compiler=PATH (but not --with-compiler PATH)@
+--   This is dislayed as:
+--    @--with-compiler=PATH@
+-- * With optional but default arguments can be given as:
+--    @--jobs or --jobs=NUM (but not --jobs NUM)@
+--   This is dislayed as:
+--    @--jobs[=NUM]@
 fmtLong :: ArgDescr a -> String -> String
 fmtLong (NoArg _) lo = "--" ++ lo
-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+fmtLong (ReqArg _ ad) lo =
+  let opt = "--" ++ lo
+   in opt ++ "=" ++ ad
+fmtLong (OptArg _ _ ad) lo =
+  let opt = "--" ++ lo
+   in opt ++ "[=" ++ ad ++ "]"
 
 wrapText :: Int -> String -> [String]
 wrapText width = map unwords . wrap 0 [] . words
@@ -230,8 +255,8 @@ longOpt ls rs optDescr = long ads arg rs
     long [ReqArg _ d] [] [] = (errReq d optStr, [])
     long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest)
     long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest)
-    long [OptArg f _] [] rest = (fromRes (f Nothing), rest)
-    long [OptArg f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)
+    long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest)
+    long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)
     long _ _ rest = (UnreqOpt ("--" ++ ls), rest)
 
 -- handle short option
@@ -249,8 +274,8 @@ shortOpt y ys rs optDescr = short ads ys rs
     short (ReqArg _ d : _) [] [] = (errReq d optStr, [])
     short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest)
     short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest)
-    short (OptArg f _ : _) [] rest = (fromRes (f Nothing), rest)
-    short (OptArg f _ : _) xs rest = (fromRes (f (Just xs)), rest)
+    short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest)
+    short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest)
     short [] [] rest = (UnreqOpt optStr, rest)
     short [] xs rest = (UnreqOpt (optStr ++ xs), rest)
 

Cabal/src/Distribution/Simple/Command.hs

@@ -74,6 +74,7 @@ module Distribution.Simple.Command
   , reqArg'
   , optArg
   , optArg'
+  , optArgDef'
   , noArg
   , boolOpt
   , boolOpt'
@@ -138,7 +139,7 @@ data OptDescr a
       OptFlags
       ArgPlaceHolder
       (ReadE (a -> a))
-      (a -> a)
+      (String, a -> a)
       (a -> [Maybe String])
   | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)]
   | BoolOpt
@@ -231,16 +232,16 @@ optArg
   :: Monoid b
   => ArgPlaceHolder
   -> ReadE b
-  -> b
+  -> (String, b)
   -> (b -> [Maybe String])
   -> MkOptDescr (a -> b) (b -> a -> a) a
-optArg ad mkflag def showflag sf lf d get set =
+optArg ad mkflag (dv, mkDef) showflag sf lf d get set =
   OptArg
     d
     (sf, lf)
     ad
     (fmap (\a b -> set (get b `mappend` a) b) mkflag)
-    (\b -> set (get b `mappend` def) b)
+    (dv, \b -> set (get b `mappend` mkDef) b)
     (showflag . get)
 
 -- | (String -> a) variant of "reqArg"
@@ -261,9 +262,16 @@ optArg'
   -> (b -> [Maybe String])
   -> MkOptDescr (a -> b) (b -> a -> a) a
 optArg' ad mkflag showflag =
-  optArg ad (succeedReadE (mkflag . Just)) def showflag
-  where
-    def = mkflag Nothing
+  optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag
+
+optArgDef'
+  :: Monoid b
+  => ArgPlaceHolder
+  -> (String, Maybe String -> b)
+  -> (b -> [Maybe String])
+  -> MkOptDescr (a -> b) (b -> a -> a) a
+optArgDef' ad (dv, mkflag) showflag =
+  optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag
 
 noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
 noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d
@@ -339,8 +347,8 @@ viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
   where
     optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) =
       [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]
-    optDescrToGetOpt (OptArg d (cs, ss) arg_desc set def _) =
-      [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]
+    optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (dv, def) _) =
+      [GetOpt.Option cs ss (GetOpt.OptArg dv set' arg_desc) d]
       where
         set' Nothing = Right def
         set' (Just txt) = runReadE set txt
@@ -374,13 +382,13 @@ liftOptDescr get' set' (ChoiceOpt opts) =
     [ (d, ff, liftSet get' set' set, (get . get'))
     | (d, ff, set, get) <- opts
     ]
-liftOptDescr get' set' (OptArg d ff ad set def get) =
+liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) =
   OptArg
     d
     ff
     ad
     (liftSet get' set' `fmap` set)
-    (liftSet get' set' def)
+    (dv, liftSet get' set' mkDef)
     (get . get')
 liftOptDescr get' set' (ReqArg d ff ad set get) =
   ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')

Cabal/src/Distribution/Simple/Setup/Common.hs

@@ -282,7 +282,7 @@ optionVerbosity get set =
     ( optArg
         "n"
         (fmap Flag flagToVerbosity)
-        (Flag verbose) -- default Value if no n is given
+        (show verbose, Flag verbose) -- default Value if no n is given
         (fmap (Just . showForCabal) . flagToList)
     )
 
@@ -300,7 +300,7 @@ optionNumJobs get set =
     ( optArg
         "NUM"
         (fmap Flag numJobsParser)
-        (Flag Nothing)
+        ("$ncpus", Flag Nothing)
         (map (Just . maybe "$ncpus" show) . flagToList)
     )
   where

Cabal/src/Distribution/Simple/Setup/Config.hs

@@ -541,9 +541,9 @@ configureOptions showOrParseArgs =
           "optimization"
           configOptimization
           (\v flags -> flags{configOptimization = v})
-          [ optArg'
+          [ optArgDef'
               "n"
-              (Flag . flagToOptimisationLevel)
+              (show NoOptimisation, Flag . flagToOptimisationLevel)
               ( \f -> case f of
                   Flag NoOptimisation -> []
                   Flag NormalOptimisation -> [Nothing]

cabal-install/src/Distribution/Client/CmdOutdated.hs

@@ -281,7 +281,7 @@ outdatedOptions _showOrParseArgs =
       ( optArg
           "PKGS"
           ignoreMajorVersionBumpsParser
-          (Just IgnoreMajorVersionBumpsAll)
+          ("", Just IgnoreMajorVersionBumpsAll)
           ignoreMajorVersionBumpsPrinter
       )
   ]

cabal-install/src/Distribution/Client/Setup.hs

@@ -934,7 +934,7 @@ configureExOptions _showOrParseArgs src =
       ( optArg
           "DEPS"
           (parsecToReadEErr unexpectMsgString relaxDepsParser)
-          (Just RelaxDepsAll)
+          (show RelaxDepsAll, Just RelaxDepsAll)
           relaxDepsPrinter
       )
   , option
@@ -946,7 +946,7 @@ configureExOptions _showOrParseArgs src =
       ( optArg
           "DEPS"
           (parsecToReadEErr unexpectMsgString relaxDepsParser)
-          (Just RelaxDepsAll)
+          (show RelaxDepsAll, Just RelaxDepsAll)
           relaxDepsPrinter
       )
   , option
@@ -1766,7 +1766,7 @@ getCommand =
                     (const "invalid source-repository")
                     (fmap (toFlag . Just) parsec)
                 )
-                (Flag Nothing)
+                ("", Flag Nothing)
                 (map (fmap show) . flagToList)
             )
         , option

changelog.d/issue-8785

@@ -0,0 +1,17 @@
+synopsis: Also render short options with arguments
+packages: cabal-install
+prs: #9043
+issues: #8785
+
+description: {
+
+Show how arguments are used with both short and long forms of options:
+
+```diff
+<  -v, --verbose[=n]              Control verbosity (n is 0--3, default
+>  -v[n], --verbose[=n]           Control verbosity (n is 0--3, default
+<  -w, --with-compiler=PATH       give the path to a particular compiler
+>  -w PATH or -wPATH, --with-compiler=PATH
+```
+
+}