Skip to content
This repository
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 580 lines (501 sloc) 24.25 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Command
-- Copyright : Duncan Coutts 2007
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This is to do with command line handling. The Cabal command line is
-- organised into a number of named sub-commands (much like darcs). The
-- 'CommandUI' abstraction represents one of these sub-commands, with a name,
-- description, a set of flags. Commands can be associated with actions and
-- run. It handles some common stuff automatically, like the @--help@ and
-- command line completion flags. It is designed to allow other tools make
-- derived commands. This feature is used heavily in @cabal-install@.

module Distribution.Simple.Command (

  -- * Command interface
  CommandUI(..),
  commandShowOptions,
  CommandParse(..),
  commandParseArgs,

  -- ** Constructing commands
  ShowOrParseArgs(..),
  makeCommand,
  hiddenCommand,

  -- ** Associating actions with commands
  Command,
  commandAddAction,
  noExtraFlags,

  -- ** Running commands
  commandsRun,

-- * Option Fields
  OptionField(..), Name,

-- ** Constructing Option Fields
  option, multiOption,

-- ** Liftings & Projections
  liftOption, viewAsFieldDescr,

-- * Option Descriptions
  OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,

-- ** OptDescr 'smart' constructors
  MkOptDescr,
  reqArg, reqArg', optArg, optArg', noArg,
  boolOpt, boolOpt', choiceOpt, choiceOptFromEnum

  ) where

import Control.Monad
import Data.Char (isAlpha, toLower)
import Data.List (sortBy)
import Data.Maybe
import Data.Monoid
import qualified Distribution.GetOpt as GetOpt
import Distribution.Text
         ( Text(disp, parse) )
import Distribution.ParseUtils
import Distribution.ReadE
import Distribution.Simple.Utils (die, intercalate)
import Text.PrettyPrint ( punctuate, cat, comma, text, empty)

data CommandUI flags = CommandUI {
    -- | The name of the command as it would be entered on the command line.
    -- For example @\"build\"@.
    commandName :: String,
    -- | A short, one line description of the command to use in help texts.
    commandSynopsis :: String,
    -- | A function that maps a program name to a usage summary for this
    -- command.
    commandUsage :: String -> String,
    -- | Additional explanation of the command to use in help texts.
    commandDescription :: Maybe (String -> String),
    -- | Initial \/ empty flags
    commandDefaultFlags :: flags,
    -- | All the Option fields for this command
    commandOptions :: ShowOrParseArgs -> [OptionField flags]
  }

data ShowOrParseArgs = ShowArgs | ParseArgs
type Name = String
type Description = String

-- | We usually have a data type for storing configuration values, where
-- every field stores a configuration option, and the user sets
-- the value either via command line flags or a configuration file.
-- An individual OptionField models such a field, and we usually
-- build a list of options associated to a configuration data type.
data OptionField a = OptionField {
  optionName :: Name,
  optionDescr :: [OptDescr a] }

-- | An OptionField takes one or more OptDescrs, describing the command line
-- interface for the field.
data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder
                   (ReadE (a->a)) (a -> [String])

                 | OptArg Description OptFlags ArgPlaceHolder
                   (ReadE (a->a)) (a->a) (a -> [Maybe String])

                 | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]

                 | BoolOpt Description OptFlags{-True-} OptFlags{-False-}
                   (Bool -> a -> a) (a-> Maybe Bool)

-- | Short command line option strings
type SFlags = [Char]
-- | Long command line option strings
type LFlags = [String]
type OptFlags = (SFlags,LFlags)
type ArgPlaceHolder = String


-- | Create an option taking a single OptDescr.
-- No explicit Name is given for the Option, the name is the first LFlag given.
option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a
          -> OptionField a
option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set]
option _ _ _ _ _ _ = error $ "Distribution.command.option: "
                     ++ "An OptionField must have at least one LFlag"

-- | Create an option taking several OptDescrs.
-- You will have to give the flags and description individually to the
-- OptDescr constructor.
multiOption :: Name -> get -> set
            -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially
                                           -- applied to flags and description.
            -> OptionField a
multiOption n get set args = OptionField n [arg get set | arg <- args]

type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set
                            -> OptDescr a

-- | Create a string-valued command line interface.
reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])
                   -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg ad mkflag showflag sf lf d get set =
  ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)
  (showflag . get)

-- | Create a string-valued command line interface with a default value.
optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String])
                   -> MkOptDescr (a -> b) (b -> a -> a) a
optArg ad mkflag def 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)
               (showflag . get)

-- | (String -> a) variant of "reqArg"
reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String])
                    -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg' ad mkflag showflag =
    reqArg ad (succeedReadE mkflag) showflag

-- | (String -> a) variant of "optArg"
optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)
           -> (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

noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a
noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d

boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags
           -> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt g s sfT sfF _sf _lf@(n:_) d get set =
    BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)
boolOpt _ _ _ _ _ _ _ _ _ = error
                            "Distribution.Simple.Setup.boolOpt: unreachable"

boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags
            -> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)

-- | create a Choice option
choiceOpt :: Eq b => [(b,OptFlags,Description)]
             -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts
    where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]

-- | create a Choice option out of an enumeration type.
-- As long flags, the Show output is used. As short flags, the first character
-- which does not conflict with a previous one is used.
choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) =>
                     MkOptDescr (a -> b) (b -> a -> a) a
choiceOptFromEnum _sf _lf d get =
  choiceOpt [ (x, (sf, [map toLower $ show x]), d')
            | (x, sf) <- sflags'
            , let d' = d ++ show x]
  _sf _lf d get
  where sflags' = foldl f [] [firstOne..]
        f prev x = let prevflags = concatMap snd prev in
                       prev ++ take 1 [(x, [toLower sf])
                                      | sf <- show x, isAlpha sf
                                      , toLower sf `notElem` prevflags]
        firstOne = minBound `asTypeOf` get undefined

commandGetOpts :: ShowOrParseArgs -> CommandUI flags
                  -> [GetOpt.OptDescr (flags -> flags)]
commandGetOpts showOrParse command =
    concatMap viewAsGetOpt (commandOptions command showOrParse)

viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]
viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
  where
    optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =
         [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d]
             where set' = readEOrFail set
    optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) =
         [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]
             where set' Nothing = def
                   set' (Just txt) = readEOrFail set txt
    optDescrToGetOpt (ChoiceOpt alts) =
         [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]
    optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) =
         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ]
    optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) =
         [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ]
    optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =
         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)
         , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]

-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >
-- Choice > Opt) and consider only the first one.
viewAsFieldDescr :: OptionField a -> FieldDescr a
viewAsFieldDescr (OptionField _n []) =
  error "Distribution.command.viewAsFieldDescr: unexpected"
viewAsFieldDescr (OptionField n dd) = FieldDescr n get set
    where
      optDescr = head $ sortBy cmp dd

      cmp :: OptDescr a -> OptDescr a -> Ordering
      ReqArg{} `cmp` ReqArg{} = EQ
      ReqArg{} `cmp` _ = GT
      BoolOpt{} `cmp` ReqArg{} = LT
      BoolOpt{} `cmp` BoolOpt{} = EQ
      BoolOpt{} `cmp` _ = GT
      ChoiceOpt{} `cmp` ReqArg{} = LT
      ChoiceOpt{} `cmp` BoolOpt{} = LT
      ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
      ChoiceOpt{} `cmp` _ = GT
      OptArg{} `cmp` OptArg{} = EQ
      OptArg{} `cmp` _ = LT

-- get :: a -> Doc
      get t = case optDescr of
        ReqArg _ _ _ _ ppr ->
          (cat . punctuate comma . map text . ppr) t

        OptArg _ _ _ _ _ ppr ->
          case ppr t of [] -> empty
                        (Nothing : _) -> text "True"
                        (Just a : _) -> text a

        ChoiceOpt alts ->
          fromMaybe empty $ listToMaybe
          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]

        BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t

-- set :: LineNo -> String -> a -> ParseResult a
      set line val a =
        case optDescr of
          ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val
                                     -- We parse for a single value instead of a
                                     -- list, as one can't really implement
                                     -- parseList :: ReadE a -> ReadE [a] with
                                     -- the current ReadE definition
          ChoiceOpt{} ->
            case getChoiceByLongFlag optDescr val of
              Just f -> return (f a)
              _ -> syntaxError line val

          BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val

          OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
                                     -- Optional arguments are parsed just like
                                     -- required arguments here; we don't
                                     -- provide a method to set an OptArg field
                                     -- to the default value.

getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)
getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe
                                           [ set | (_,(_sf,lf:_), set, _) <- alts
                                                 , lf == val]

getChoiceByLongFlag _ _ =
  error "Distribution.command.getChoiceByLongFlag: expected a choice option"

getCurrentChoice :: OptDescr a -> a -> [String]
getCurrentChoice (ChoiceOpt alts) a =
    [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a]

getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr"


liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
liftOption get' set' opt =
  opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}


liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
liftOptDescr get' set' (ChoiceOpt opts) =
    ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get'))
              | (d, ff, set, get) <- opts]

liftOptDescr get' set' (OptArg d ff ad set def get) =
    OptArg d ff ad (liftSet get' set' `fmap` set)
    (liftSet get' set' def) (get . get')

liftOptDescr get' set' (ReqArg d ff ad set get) =
    ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')

liftOptDescr get' set' (BoolOpt d ffT ffF set get) =
    BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')

liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b
liftSet get' set' set x = set' (set $ get' x) x

-- | Show flags in the standard long option command line format
commandShowOptions :: CommandUI flags -> flags -> [String]
commandShowOptions command v = concat
  [ showOptDescr v od | o <- commandOptions command ParseArgs
                       , od <- optionDescr o]
  where
    maybePrefix [] = []
    maybePrefix (lOpt:_) = ["--" ++ lOpt]

    showOptDescr :: a -> OptDescr a -> [String]
    showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled)
      = case enabled x of
          Nothing -> []
          Just True -> maybePrefix lfTs
          Just False -> maybePrefix lfFs
    showOptDescr x c@ChoiceOpt{}
      = ["--" ++ val | val <- getCurrentChoice c x]
    showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)
      = [ "--"++lf++"="++flag
        | flag <- showflag x ]
    showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag)
      = [ case flag of
            Just s -> "--"++lf++"="++s
            Nothing -> "--"++lf
        | flag <- showflag x ]
    showOptDescr _ _
      = error "Distribution.Simple.Command.showOptDescr: unreachable"


commandListOptions :: CommandUI flags -> [String]
commandListOptions command =
  concatMap listOption $
    addCommonFlags ShowArgs $ -- This is a slight hack, we don't want
                              -- "--list-options" showing up in the
                              -- list options output, so use ShowArgs
      commandGetOpts ShowArgs command
  where
    listOption (GetOpt.Option shortNames longNames _ _) =
         [ "-" ++ [name] | name <- shortNames ]
      ++ [ "--" ++ name | name <- longNames ]

-- | The help text for this command with descriptions of all the options.
commandHelp :: CommandUI flags -> String -> String
commandHelp command pname =
    commandUsage command pname
 ++ (GetOpt.usageInfo ""
  . addCommonFlags ShowArgs
  $ commandGetOpts ShowArgs command)
 ++ case commandDescription command of
      Nothing -> ""
      Just desc -> '\n': desc pname

-- | Make a Command from standard 'GetOpt' options.
makeCommand :: String -- ^ name
            -> String -- ^ short description
            -> Maybe (String -> String) -- ^ long description
            -> flags -- ^ initial\/empty flags
            -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options
            -> CommandUI flags
makeCommand name shortDesc longDesc defaultFlags options =
  CommandUI {
    commandName = name,
    commandSynopsis = shortDesc,
    commandDescription = longDesc,
    commandUsage = usage,
    commandDefaultFlags = defaultFlags,
    commandOptions = options
  }
  where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
                   ++ "Flags for " ++ name ++ ":"

-- | Common flags that apply to every command
data CommonFlag = HelpFlag | ListOptionsFlag

commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]
commonFlags showOrParseArgs = case showOrParseArgs of
  ShowArgs -> [help]
  ParseArgs -> [help, list]
 where
    help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag)
             "Show this help text"
    helpShortFlags = case showOrParseArgs of
      ShowArgs -> ['h']
      ParseArgs -> ['h', '?']
    list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag)
             "Print a list of command line flags"

addCommonFlags :: ShowOrParseArgs
               -> [GetOpt.OptDescr a]
               -> [GetOpt.OptDescr (Either CommonFlag a)]
addCommonFlags showOrParseArgs options =
     map (fmapOptDesc Left) (commonFlags showOrParseArgs)
  ++ map (fmapOptDesc Right) options
  where fmapOptDesc f (GetOpt.Option s l d m) =
                       GetOpt.Option s l (fmapArgDesc f d) m
        fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a)
        fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d
        fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d

-- | Parse a bunch of command line arguments
--
commandParseArgs :: CommandUI flags
                 -> Bool -- ^ Is the command a global or subcommand?
                 -> [String]
                 -> CommandParse (flags -> flags, [String])
commandParseArgs command global args =
  let options = addCommonFlags ParseArgs
              $ commandGetOpts ParseArgs command
      order | global = GetOpt.RequireOrder
            | otherwise = GetOpt.Permute
  in case GetOpt.getOpt' order options args of
    (flags, _, _, _)
      | any listFlag flags -> CommandList (commandListOptions command)
      | any helpFlag flags -> CommandHelp (commandHelp command)
      where listFlag (Left ListOptionsFlag) = True; listFlag _ = False
            helpFlag (Left HelpFlag) = True; helpFlag _ = False
    (flags, opts, opts', [])
      | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts')
      | otherwise -> CommandErrors (unrecognised opts')
    (_, _, _, errs) -> CommandErrors errs

  where -- Note: It is crucial to use reverse function composition here or to
        -- reverse the flags here as we want to process the flags left to right
        -- but data flow in function composition is right to left.
        accum flags = foldr (flip (.)) id [ f | Right f <- flags ]
        unrecognised opts = [ "unrecognized "
                              ++ "'" ++ (commandName command) ++ "'"
                              ++ " option `" ++ opt ++ "'\n"
                            | opt <- opts ]
        -- For unrecognised global flags we put them in the position just after
        -- the command, if there is one. This gives us a chance to parse them
        -- as sub-command rather than global flags.
        mix [] ys = ys
        mix (x:xs) ys = x:ys++xs

data CommandParse flags = CommandHelp (String -> String)
                        | CommandList [String]
                        | CommandErrors [String]
                        | CommandReadyToGo flags
instance Functor CommandParse where
  fmap _ (CommandHelp help) = CommandHelp help
  fmap _ (CommandList opts) = CommandList opts
  fmap _ (CommandErrors errs) = CommandErrors errs
  fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)


data CommandType = NormalCommand | HiddenCommand
data Command action =
  Command String String ([String] -> CommandParse action) CommandType

-- | Mark command as hidden. Hidden commands don't show up in the 'progname
-- help' or 'progname --help' output.
hiddenCommand :: Command action -> Command action
hiddenCommand (Command name synopsys f _cmdType) =
  Command name synopsys f HiddenCommand

commandAddAction :: CommandUI flags
                 -> (flags -> [String] -> action)
                 -> Command action
commandAddAction command action =
  Command (commandName command)
          (commandSynopsis command)
          (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)
          NormalCommand

  where applyDefaultArgs mkflags args =
          let flags = mkflags (commandDefaultFlags command)
           in action flags args

commandsRun :: CommandUI a
            -> [Command action]
            -> [String]
            -> CommandParse (a, CommandParse action)
commandsRun globalCommand commands args =
  case commandParseArgs globalCommand' True args of
    CommandHelp help -> CommandHelp help
    CommandList opts -> CommandList (opts ++ commandNames)
    CommandErrors errs -> CommandErrors errs
    CommandReadyToGo (mkflags, args') -> case args' of
      ("help":cmdArgs) -> handleHelpCommand cmdArgs
      (name:cmdArgs) -> case lookupCommand name of
        [Command _ _ action _]
          -> CommandReadyToGo (flags, action cmdArgs)
        _ -> CommandReadyToGo (flags, badCommand name)
      [] -> CommandReadyToGo (flags, noCommand)
     where flags = mkflags (commandDefaultFlags globalCommand)

 where
    lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands'
                                , cname' == cname ]
    noCommand = CommandErrors ["no command given (try --help)\n"]
    badCommand cname = CommandErrors ["unrecognised command: " ++ cname
                                   ++ " (try --help)\n"]
    commands' = commands ++ [commandAddAction helpCommandUI undefined]
    commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ]
    globalCommand' = globalCommand {
      commandUsage = \pname ->
           (case commandUsage globalCommand pname of
             "" -> ""
             original -> original ++ "\n")
        ++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n"
        ++ " or: " ++ pname ++ " [GLOBAL FLAGS]\n\n"
        ++ "Global flags:",
      commandDescription = Just $ \pname ->
           "Commands:\n"
        ++ unlines [ " " ++ align name ++ " " ++ description
                   | Command name description _ NormalCommand <- commands' ]
        ++ case commandDescription globalCommand of
             Nothing -> ""
             Just desc -> '\n': desc pname
    }
      where maxlen = maximum
                    [ length name | Command name _ _ NormalCommand <- commands' ]
            align str = str ++ replicate (maxlen - length str) ' '

    -- A bit of a hack: support "prog help" as a synonym of "prog --help"
    -- furthermore, support "prog help command" as "prog command --help"
    handleHelpCommand cmdArgs =
      case commandParseArgs helpCommandUI True cmdArgs of
        CommandHelp help -> CommandHelp help
        CommandList list -> CommandList (list ++ commandNames)
        CommandErrors _ -> CommandHelp globalHelp
        CommandReadyToGo (_,[]) -> CommandHelp globalHelp
        CommandReadyToGo (_,(name:cmdArgs')) ->
          case lookupCommand name of
            [Command _ _ action _] ->
              case action ("--help":cmdArgs') of
                CommandHelp help -> CommandHelp help
                CommandList _ -> CommandList []
                _ -> CommandHelp globalHelp
            _ -> badCommand name

     where globalHelp = commandHelp globalCommand'
    helpCommandUI =
      (makeCommand "help" "Help about commands." Nothing () (const [])) {
        commandUsage = \pname ->
             "Usage: " ++ pname ++ " help [FLAGS]\n"
          ++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"
          ++ "Flags for help:"
      }

-- | Utility function, many commands do not accept additional flags. This
-- action fails with a helpful error message if the user supplies any extra.
--
noExtraFlags :: [String] -> IO ()
noExtraFlags [] = return ()
noExtraFlags extraFlags =
  die $ "Unrecognised flags: " ++ intercalate ", " extraFlags
--TODO: eliminate this function and turn it into a variant on commandAddAction
-- instead like commandAddActionNoArgs that doesn't supply the [String]
Something went wrong with that request. Please try again.