Cabal/src/Distribution/Simple/Command.hs

   1 {-# LANGUAGE ExistentialQuantification #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Simple.Command
   9 -- Copyright   :  Duncan Coutts 2007
  10 -- License     :  BSD3
  11 --
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Portability :  non-portable (ExistentialQuantification)
  14 --
  15 -- This is to do with command line handling. The Cabal command line is
  16 -- organised into a number of named sub-commands (much like darcs). The
  17 -- 'CommandUI' abstraction represents one of these sub-commands, with a name,
  18 -- description, a set of flags. Commands can be associated with actions and
  19 -- run. It handles some common stuff automatically, like the @--help@ and
  20 -- command line completion flags. It is designed to allow other tools make
  21 -- derived commands. This feature is used heavily in @cabal-install@.
  22 module Distribution.Simple.Command
  23   ( -- * Command interface
  24     CommandUI (..)
  25   , commandShowOptions
  26   , CommandParse (..)
  27   , commandParseArgs
  28   , getNormalCommandDescriptions
  29   , helpCommandUI
  30
  31     -- ** Constructing commands
  32   , ShowOrParseArgs (..)
  33   , usageDefault
  34   , usageAlternatives
  35   , mkCommandUI
  36   , hiddenCommand
  37
  38     -- ** Associating actions with commands
  39   , Command
  40   , commandAddAction
  41   , noExtraFlags
  42
  43     -- ** Building lists of commands
  44   , CommandType (..)
  45   , CommandSpec (..)
  46   , commandFromSpec
  47
  48     -- ** Running commands
  49   , commandsRun
  50
  51     -- * Option Fields
  52   , OptionField (..)
  53   , Name
  54
  55     -- ** Constructing Option Fields
  56   , option
  57   , multiOption
  58
  59     -- ** Liftings & Projections
  60   , liftOption
  61   , liftOptionL
  62
  63     -- * Option Descriptions
  64   , OptDescr (..)
  65   , Description
  66   , SFlags
  67   , LFlags
  68   , OptFlags
  69   , ArgPlaceHolder
  70
  71     -- ** OptDescr 'smart' constructors
  72   , MkOptDescr
  73   , reqArg
  74   , reqArg'
  75   , optArg
  76   , optArg'
  77   , optArgDef'
  78   , noArg
  79   , boolOpt
  80   , boolOpt'
  81   , choiceOpt
  82   , choiceOptFromEnum
  83   ) where
  84
  85 import Distribution.Compat.Prelude hiding (get)
  86 import Prelude ()
  87
  88 import qualified Data.Array as Array
  89 import qualified Data.List as List
  90 import Distribution.Compat.Lens (ALens', (#~), (^#))
  91 import qualified Distribution.GetOpt as GetOpt
  92 import Distribution.ReadE
  93 import Distribution.Simple.Utils
  94
  95 data CommandUI flags = CommandUI
  96   { commandName :: String
  97   -- ^ The name of the command as it would be entered on the command line.
  98   -- For example @\"build\"@.
  99   , commandSynopsis :: String
 100   -- ^ A short, one line description of the command to use in help texts.
 101   , commandUsage :: String -> String
 102   -- ^ A function that maps a program name to a usage summary for this
 103   -- command.
 104   , commandDescription :: Maybe (String -> String)
 105   -- ^ Additional explanation of the command to use in help texts.
 106   , commandNotes :: Maybe (String -> String)
 107   -- ^ Post-Usage notes and examples in help texts
 108   , commandDefaultFlags :: flags
 109   -- ^ Initial \/ empty flags
 110   , commandOptions :: ShowOrParseArgs -> [OptionField flags]
 111   -- ^ All the Option fields for this command
 112   }
 113
 114 data ShowOrParseArgs = ShowArgs | ParseArgs
 115 type Name = String
 116 type Description = String
 117
 118 -- | We usually have a data type for storing configuration values, where
 119 --   every field stores a configuration option, and the user sets
 120 --   the value either via command line flags or a configuration file.
 121 --   An individual OptionField models such a field, and we usually
 122 --   build a list of options associated to a configuration data type.
 123 data OptionField a = OptionField
 124   { optionName :: Name
 125   , optionDescr :: [OptDescr a]
 126   }
 127
 128 -- | An OptionField takes one or more OptDescrs, describing the command line
 129 -- interface for the field.
 130 data OptDescr a
 131   = ReqArg
 132       Description
 133       OptFlags
 134       ArgPlaceHolder
 135       (ReadE (a -> a))
 136       (a -> [String])
 137   | OptArg
 138       Description
 139       OptFlags
 140       ArgPlaceHolder
 141       (ReadE (a -> a))
 142       (String, a -> a)
 143       (a -> [Maybe String])
 144   | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)]
 145   | BoolOpt
 146       Description
 147       OptFlags {-True-}
 148       OptFlags {-False-}
 149       (Bool -> a -> a)
 150       (a -> Maybe Bool)
 151
 152 -- | Short command line option strings
 153 type SFlags = [Char]
 154
 155 -- | Long command line option strings
 156 type LFlags = [String]
 157
 158 type OptFlags = (SFlags, LFlags)
 159 type ArgPlaceHolder = String
 160
 161 -- | Create an option taking a single OptDescr.
 162 --   No explicit Name is given for the Option, the name is the first LFlag given.
 163 --
 164 -- Example: @'option' sf lf d get set@
 165 -- * @sf@: Short option name, for example: @[\'d\']@. No hyphen permitted.
 166 -- * @lf@: Long option name, for example: @["debug"]@. No hyphens permitted.
 167 -- * @d@: Description of the option, shown to the user in help messages.
 168 -- * @get@: Get the current value of the flag.
 169 -- * @set@: Set the value of the flag. Gets the current value of the flag as a
 170 --          parameter.
 171 option
 172   :: SFlags
 173   -> LFlags
 174   -> Description
 175   -> get
 176   -> set
 177   -> MkOptDescr get set a
 178   -> OptionField a
 179 option sf lf@(n : _) d get set arg = OptionField n [arg sf lf d get set]
 180 option _ _ _ _ _ _ =
 181   error $
 182     "Distribution.command.option: "
 183       ++ "An OptionField must have at least one LFlag"
 184
 185 -- | Create an option taking several OptDescrs.
 186 --   You will have to give the flags and description individually to the
 187 --   OptDescr constructor.
 188 multiOption
 189   :: Name
 190   -> get
 191   -> set
 192   -> [get -> set -> OptDescr a]
 193   -- ^ MkOptDescr constructors partially
 194   --  applied to flags and description.
 195   -> OptionField a
 196 multiOption n get set args = OptionField n [arg get set | arg <- args]
 197
 198 type MkOptDescr get set a =
 199   SFlags
 200   -> LFlags
 201   -> Description
 202   -> get
 203   -> set
 204   -> OptDescr a
 205
 206 -- | Create a string-valued command line interface.
 207 -- Usually called in the context of 'option' or 'multiOption'.
 208 --
 209 -- Example: @'reqArg' ad mkflag showflag@
 210 --
 211 -- * @ad@: Placeholder shown to the user, e.g. @"FILES"@ if files are expected
 212 --         parameters.
 213 -- * @mkflag@: How to parse the argument into the option.
 214 -- * @showflag@: If parsing goes wrong, display a useful error message to
 215 --               the user.
 216 reqArg
 217   :: Monoid b
 218   => ArgPlaceHolder
 219   -> ReadE b
 220   -> (b -> [String])
 221   -> MkOptDescr (a -> b) (b -> a -> a) a
 222 reqArg ad mkflag showflag sf lf d get set =
 223   ReqArg
 224     d
 225     (sf, lf)
 226     ad
 227     (fmap (\a b -> set (get b `mappend` a) b) mkflag)
 228     (showflag . get)
 229
 230 -- | Create a string-valued command line interface with a default value.
 231 optArg
 232   :: Monoid b
 233   => ArgPlaceHolder
 234   -> ReadE b
 235   -> (String, b)
 236   -> (b -> [Maybe String])
 237   -> MkOptDescr (a -> b) (b -> a -> a) a
 238 optArg ad mkflag (dv, mkDef) showflag sf lf d get set =
 239   OptArg
 240     d
 241     (sf, lf)
 242     ad
 243     (fmap (\a b -> set (get b `mappend` a) b) mkflag)
 244     (dv, \b -> set (get b `mappend` mkDef) b)
 245     (showflag . get)
 246
 247 -- | (String -> a) variant of "reqArg"
 248 reqArg'
 249   :: Monoid b
 250   => ArgPlaceHolder
 251   -> (String -> b)
 252   -> (b -> [String])
 253   -> MkOptDescr (a -> b) (b -> a -> a) a
 254 reqArg' ad mkflag showflag =
 255   reqArg ad (succeedReadE mkflag) showflag
 256
 257 -- | (String -> a) variant of "optArg"
 258 optArg'
 259   :: Monoid b
 260   => ArgPlaceHolder
 261   -> (Maybe String -> b)
 262   -> (b -> [Maybe String])
 263   -> MkOptDescr (a -> b) (b -> a -> a) a
 264 optArg' ad mkflag showflag =
 265   optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag
 266
 267 optArgDef'
 268   :: Monoid b
 269   => ArgPlaceHolder
 270   -> (String, Maybe String -> b)
 271   -> (b -> [Maybe String])
 272   -> MkOptDescr (a -> b) (b -> a -> a) a
 273 optArgDef' ad (dv, mkflag) showflag =
 274   optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag
 275
 276 noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
 277 noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d
 278
 279 boolOpt
 280   :: (b -> Maybe Bool)
 281   -> (Bool -> b)
 282   -> SFlags
 283   -> SFlags
 284   -> MkOptDescr (a -> b) (b -> a -> a) a
 285 boolOpt g s sfT sfF _sf _lf@(n : _) d get set =
 286   BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get)
 287 boolOpt _ _ _ _ _ _ _ _ _ =
 288   error
 289     "Distribution.Simple.Setup.boolOpt: unreachable"
 290
 291 boolOpt'
 292   :: (b -> Maybe Bool)
 293   -> (Bool -> b)
 294   -> OptFlags
 295   -> OptFlags
 296   -> MkOptDescr (a -> b) (b -> a -> a) a
 297 boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get)
 298
 299 -- | create a Choice option
 300 choiceOpt
 301   :: Eq b
 302   => [(b, OptFlags, Description)]
 303   -> MkOptDescr (a -> b) (b -> a -> a) a
 304 choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts
 305   where
 306     alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff]
 307
 308 -- | create a Choice option out of an enumeration type.
 309 --   As long flags, the Show output is used. As short flags, the first character
 310 --   which does not conflict with a previous one is used.
 311 choiceOptFromEnum
 312   :: (Bounded b, Enum b, Show b, Eq b)
 313   => MkOptDescr (a -> b) (b -> a -> a) a
 314 choiceOptFromEnum _sf _lf d get =
 315   choiceOpt
 316     [ (x, (sf, [map toLower $ show x]), d')
 317     | (x, sf) <- sflags'
 318     , let d' = d ++ show x
 319     ]
 320     _sf
 321     _lf
 322     d
 323     get
 324   where
 325     sflags' = foldl f [] [firstOne ..]
 326     f prev x =
 327       let prevflags = concatMap snd prev
 328        in prev
 329             ++ take
 330               1
 331               [ (x, [toLower sf])
 332               | sf <- show x
 333               , isAlpha sf
 334               , toLower sf `notElem` prevflags
 335               ]
 336     firstOne = minBound `asTypeOf` get undefined
 337
 338 commandGetOpts
 339   :: ShowOrParseArgs
 340   -> CommandUI flags
 341   -> [GetOpt.OptDescr (flags -> flags)]
 342 commandGetOpts showOrParse command =
 343   concatMap viewAsGetOpt (commandOptions command showOrParse)
 344
 345 viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)]
 346 viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
 347   where
 348     optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) =
 349       [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]
 350     optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (dv, def) _) =
 351       [GetOpt.Option cs ss (GetOpt.OptArg dv set' arg_desc) d]
 352       where
 353         set' Nothing = Right def
 354         set' (Just txt) = runReadE set txt
 355     optDescrToGetOpt (ChoiceOpt alts) =
 356       [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d, (sf, lf), set, _) <- alts]
 357     optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) =
 358       [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d]
 359     optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) =
 360       [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d]
 361     optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) =
 362       [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)
 363       , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d)
 364       ]
 365
 366 getCurrentChoice :: OptDescr a -> a -> [String]
 367 getCurrentChoice (ChoiceOpt alts) a =
 368   [lf | (_, (_sf, lf : _), _, currentChoice) <- alts, currentChoice a]
 369 getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr"
 370
 371 liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
 372 liftOption get' set' opt =
 373   opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt}
 374
 375 -- | @since 3.4.0.0
 376 liftOptionL :: ALens' b a -> OptionField a -> OptionField b
 377 liftOptionL l = liftOption (^# l) (l #~)
 378
 379 liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
 380 liftOptDescr get' set' (ChoiceOpt opts) =
 381   ChoiceOpt
 382     [ (d, ff, liftSet get' set' set, (get . get'))
 383     | (d, ff, set, get) <- opts
 384     ]
 385 liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) =
 386   OptArg
 387     d
 388     ff
 389     ad
 390     (liftSet get' set' `fmap` set)
 391     (dv, liftSet get' set' mkDef)
 392     (get . get')
 393 liftOptDescr get' set' (ReqArg d ff ad set get) =
 394   ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')
 395 liftOptDescr get' set' (BoolOpt d ffT ffF set get) =
 396   BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')
 397
 398 liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b
 399 liftSet get' set' set x = set' (set $ get' x) x
 400
 401 -- | Show flags in the standard long option command line format
 402 commandShowOptions :: CommandUI flags -> flags -> [String]
 403 commandShowOptions command v =
 404   concat
 405     [ showOptDescr v od | o <- commandOptions command ParseArgs, od <- optionDescr o
 406     ]
 407   where
 408     maybePrefix [] = []
 409     maybePrefix (lOpt : _) = ["--" ++ lOpt]
 410
 411     showOptDescr :: a -> OptDescr a -> [String]
 412     showOptDescr x (BoolOpt _ (_, lfTs) (_, lfFs) _ enabled) =
 413       case enabled x of
 414         Nothing -> []
 415         Just True -> maybePrefix lfTs
 416         Just False -> maybePrefix lfFs
 417     showOptDescr x c@ChoiceOpt{} =
 418       ["--" ++ val | val <- getCurrentChoice c x]
 419     showOptDescr x (ReqArg _ (_ssff, lf : _) _ _ showflag) =
 420       [ "--" ++ lf ++ "=" ++ flag
 421       | flag <- showflag x
 422       ]
 423     showOptDescr x (OptArg _ (_ssff, lf : _) _ _ _ showflag) =
 424       [ case flag of
 425         Just s -> "--" ++ lf ++ "=" ++ s
 426         Nothing -> "--" ++ lf
 427       | flag <- showflag x
 428       ]
 429     showOptDescr _ _ =
 430       error "Distribution.Simple.Command.showOptDescr: unreachable"
 431
 432 commandListOptions :: CommandUI flags -> [String]
 433 commandListOptions command =
 434   concatMap listOption $
 435     addCommonFlags ShowArgs $ -- This is a slight hack, we don't want
 436     -- "--list-options" showing up in the
 437     -- list options output, so use ShowArgs
 438       commandGetOpts ShowArgs command
 439   where
 440     listOption (GetOpt.Option shortNames longNames _ _) =
 441       ["-" ++ [name] | name <- shortNames]
 442         ++ ["--" ++ name | name <- longNames]
 443
 444 -- | The help text for this command with descriptions of all the options.
 445 commandHelp :: CommandUI flags -> String -> String
 446 commandHelp command pname =
 447   commandSynopsis command
 448     ++ "\n\n"
 449     ++ commandUsage command pname
 450     ++ ( case commandDescription command of
 451           Nothing -> ""
 452           Just desc -> '\n' : desc pname
 453        )
 454     ++ "\n"
 455     ++ ( if cname == ""
 456           then "Global flags:"
 457           else "Flags for " ++ cname ++ ":"
 458        )
 459     ++ ( GetOpt.usageInfo ""
 460           . addCommonFlags ShowArgs
 461           $ commandGetOpts ShowArgs command
 462        )
 463     ++ ( case commandNotes command of
 464           Nothing -> ""
 465           Just notes -> '\n' : notes pname
 466        )
 467   where
 468     cname = commandName command
 469
 470 -- | Default "usage" documentation text for commands.
 471 usageDefault :: String -> String -> String
 472 usageDefault name pname =
 473   "Usage: "
 474     ++ pname
 475     ++ " "
 476     ++ name
 477     ++ " [FLAGS]\n\n"
 478     ++ "Flags for "
 479     ++ name
 480     ++ ":"
 481
 482 -- | Create "usage" documentation from a list of parameter
 483 --   configurations.
 484 usageAlternatives :: String -> [String] -> String -> String
 485 usageAlternatives name strs pname =
 486   unlines
 487     [ start ++ pname ++ " " ++ name ++ " " ++ s
 488     | let starts = "Usage: " : repeat "   or: "
 489     , (start, s) <- zip starts strs
 490     ]
 491
 492 -- | Make a Command from standard 'GetOpt' options.
 493 mkCommandUI
 494   :: String
 495   -- ^ name
 496   -> String
 497   -- ^ synopsis
 498   -> [String]
 499   -- ^ usage alternatives
 500   -> flags
 501   -- ^ initial\/empty flags
 502   -> (ShowOrParseArgs -> [OptionField flags])
 503   -- ^ options
 504   -> CommandUI flags
 505 mkCommandUI name synopsis usages flags options =
 506   CommandUI
 507     { commandName = name
 508     , commandSynopsis = synopsis
 509     , commandDescription = Nothing
 510     , commandNotes = Nothing
 511     , commandUsage = usageAlternatives name usages
 512     , commandDefaultFlags = flags
 513     , commandOptions = options
 514     }
 515
 516 -- | Common flags that apply to every command
 517 data CommonFlag = HelpFlag | ListOptionsFlag
 518
 519 commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]
 520 commonFlags showOrParseArgs = case showOrParseArgs of
 521   ShowArgs -> [help]
 522   ParseArgs -> [help, list]
 523   where
 524     help =
 525       GetOpt.Option
 526         helpShortFlags
 527         ["help"]
 528         (GetOpt.NoArg HelpFlag)
 529         "Show this help text"
 530     helpShortFlags = case showOrParseArgs of
 531       ShowArgs -> ['h']
 532       ParseArgs -> ['h', '?']
 533     list =
 534       GetOpt.Option
 535         []
 536         ["list-options"]
 537         (GetOpt.NoArg ListOptionsFlag)
 538         "Print a list of command line flags"
 539
 540 addCommonFlags
 541   :: ShowOrParseArgs
 542   -> [GetOpt.OptDescr a]
 543   -> [GetOpt.OptDescr (Either CommonFlag a)]
 544 addCommonFlags showOrParseArgs options =
 545   map (fmap Left) (commonFlags showOrParseArgs)
 546     ++ map (fmap Right) options
 547
 548 -- | Parse a bunch of command line arguments
 549 commandParseArgs
 550   :: CommandUI flags
 551   -> Bool
 552   -- ^ Is the command a global or subcommand?
 553   -> [String]
 554   -> CommandParse (flags -> flags, [String])
 555 commandParseArgs command global args =
 556   let options =
 557         addCommonFlags ParseArgs $
 558           commandGetOpts ParseArgs command
 559       order
 560         | global = GetOpt.RequireOrder
 561         | otherwise = GetOpt.Permute
 562    in case GetOpt.getOpt' order options args of
 563         (flags, _, _, _)
 564           | any listFlag flags -> CommandList (commandListOptions command)
 565           | any helpFlag flags -> CommandHelp (commandHelp command)
 566           where
 567             listFlag (Left ListOptionsFlag) = True; listFlag _ = False
 568             helpFlag (Left HelpFlag) = True; helpFlag _ = False
 569         (flags, opts, opts', [])
 570           | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts')
 571           | otherwise -> CommandErrors (unrecognised opts')
 572         (_, _, _, errs) -> CommandErrors errs
 573   where
 574     -- Note: It is crucial to use reverse function composition here or to
 575     -- reverse the flags here as we want to process the flags left to right
 576     -- but data flow in function composition is right to left.
 577     accum flags = foldr (flip (.)) id [f | Right f <- flags]
 578     unrecognised opts =
 579       [ "unrecognized "
 580         ++ "'"
 581         ++ (commandName command)
 582         ++ "'"
 583         ++ " option `"
 584         ++ opt
 585         ++ "'\n"
 586       | opt <- opts
 587       ]
 588     -- For unrecognised global flags we put them in the position just after
 589     -- the command, if there is one. This gives us a chance to parse them
 590     -- as sub-command rather than global flags.
 591     mix [] ys = ys
 592     mix (x : xs) ys = x : ys ++ xs
 593
 594 data CommandParse flags
 595   = CommandHelp (String -> String)
 596   | CommandList [String]
 597   | CommandErrors [String]
 598   | CommandReadyToGo flags
 599 instance Functor CommandParse where
 600   fmap _ (CommandHelp help) = CommandHelp help
 601   fmap _ (CommandList opts) = CommandList opts
 602   fmap _ (CommandErrors errs) = CommandErrors errs
 603   fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)
 604
 605 data CommandType = NormalCommand | HiddenCommand
 606 data Command action
 607   = Command String String ([String] -> CommandParse action) CommandType
 608
 609 -- | Mark command as hidden. Hidden commands don't show up in the 'progname
 610 -- help' or 'progname --help' output.
 611 hiddenCommand :: Command action -> Command action
 612 hiddenCommand (Command name synopsys f _cmdType) =
 613   Command name synopsys f HiddenCommand
 614
 615 commandAddAction
 616   :: CommandUI flags
 617   -> (flags -> [String] -> action)
 618   -> Command action
 619 commandAddAction command action =
 620   Command
 621     (commandName command)
 622     (commandSynopsis command)
 623     (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)
 624     NormalCommand
 625   where
 626     applyDefaultArgs mkflags args =
 627       let flags = mkflags (commandDefaultFlags command)
 628        in action flags args
 629
 630 commandsRun
 631   :: CommandUI a
 632   -> [Command action]
 633   -> [String]
 634   -> CommandParse (a, CommandParse action)
 635 commandsRun globalCommand commands args =
 636   case commandParseArgs globalCommand True args of
 637     CommandHelp help -> CommandHelp help
 638     CommandList opts -> CommandList (opts ++ commandNames)
 639     CommandErrors errs -> CommandErrors errs
 640     CommandReadyToGo (mkflags, args') -> case args' of
 641       ("help" : cmdArgs) -> handleHelpCommand cmdArgs
 642       (name : cmdArgs) -> case lookupCommand name of
 643         [Command _ _ action _] ->
 644           CommandReadyToGo (flags, action cmdArgs)
 645         _ -> CommandReadyToGo (flags, badCommand name)
 646       [] -> CommandReadyToGo (flags, noCommand)
 647       where
 648         flags = mkflags (commandDefaultFlags globalCommand)
 649   where
 650     lookupCommand cname =
 651       [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname
 652       ]
 653     noCommand = CommandErrors ["no command given (try --help)\n"]
 654
 655     -- Print suggested command if edit distance is < 5
 656     badCommand :: String -> CommandParse a
 657     badCommand cname =
 658       case eDists of
 659         [] -> CommandErrors [unErr]
 660         (s : _) ->
 661           CommandErrors
 662             [ unErr
 663             , "Maybe you meant `" ++ s ++ "`?\n"
 664             ]
 665       where
 666         eDists =
 667           map fst . List.sortBy (comparing snd) $
 668             [ (cname', dist)
 669             | (Command cname' _ _ _) <- commands'
 670             , let dist = editDistance cname' cname
 671             , dist < 5
 672             ]
 673         unErr = "unrecognised command: " ++ cname ++ " (try --help)"
 674
 675     commands' = commands ++ [commandAddAction helpCommandUI undefined]
 676     commandNames = [name | (Command name _ _ NormalCommand) <- commands']
 677
 678     -- A bit of a hack: support "prog help" as a synonym of "prog --help"
 679     -- furthermore, support "prog help command" as "prog command --help"
 680     handleHelpCommand cmdArgs =
 681       case commandParseArgs helpCommandUI True cmdArgs of
 682         CommandHelp help -> CommandHelp help
 683         CommandList list -> CommandList (list ++ commandNames)
 684         CommandErrors _ -> CommandHelp globalHelp
 685         CommandReadyToGo (_, []) -> CommandHelp globalHelp
 686         CommandReadyToGo (_, (name : cmdArgs')) ->
 687           case lookupCommand name of
 688             [Command _ _ action _] ->
 689               case action ("--help" : cmdArgs') of
 690                 CommandHelp help -> CommandHelp help
 691                 CommandList _ -> CommandList []
 692                 _ -> CommandHelp globalHelp
 693             _ -> badCommand name
 694       where
 695         globalHelp = commandHelp globalCommand
 696
 697 -- Levenshtein distance, from https://wiki.haskell.org/Edit_distance
 698 -- (Author: JeanPhilippeBernardy, Simple Permissive Licence)
 699 editDistance :: Eq a => [a] -> [a] -> Int
 700 editDistance xs ys = table Array.! (m, n)
 701   where
 702     (m, n) = (length xs, length ys)
 703     x = Array.array (1, m) (zip [1 ..] xs)
 704     y = Array.array (1, n) (zip [1 ..] ys)
 705
 706     table :: Array.Array (Int, Int) Int
 707     table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds]
 708     bnds = ((0, 0), (m, n))
 709
 710     dist (0, j) = j
 711     dist (i, 0) = i
 712     dist (i, j) =
 713       minimum
 714         [ table Array.! (i - 1, j) + 1
 715         , table Array.! (i, j - 1) + 1
 716         , if x Array.! i == y Array.! j
 717             then table Array.! (i - 1, j - 1)
 718             else 1 + table Array.! (i - 1, j - 1)
 719         ]
 720
 721 -- | Utility function, many commands do not accept additional flags. This
 722 -- action fails with a helpful error message if the user supplies any extra.
 723 noExtraFlags :: [String] -> IO ()
 724 noExtraFlags [] = return ()
 725 noExtraFlags extraFlags =
 726   dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags
 727
 728 -- TODO: eliminate this function and turn it into a variant on commandAddAction
 729 --      instead like commandAddActionNoArgs that doesn't supply the [String]
 730
 731 -- | Helper function for creating globalCommand description
 732 getNormalCommandDescriptions :: [Command action] -> [(String, String)]
 733 getNormalCommandDescriptions cmds =
 734   [ (name, description)
 735   | Command name description _ NormalCommand <- cmds
 736   ]
 737
 738 helpCommandUI :: CommandUI ()
 739 helpCommandUI =
 740   ( mkCommandUI
 741       "help"
 742       "Help about commands."
 743       ["[FLAGS]", "COMMAND [FLAGS]"]
 744       ()
 745       (const [])
 746   )
 747     { commandNotes = Just $ \pname ->
 748         "Examples:\n"
 749           ++ "  "
 750           ++ pname
 751           ++ " help help\n"
 752           ++ "    Oh, apparently you already know this.\n"
 753     }
 754
 755 -- | wraps a @CommandUI@ together with a function that turns it into a @Command@.
 756 -- By hiding the type of flags for the UI allows construction of a list of all UIs at the
 757 -- top level of the program. That list can then be used for generation of manual page
 758 -- as well as for executing the selected command.
 759 data CommandSpec action
 760   = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType
 761
 762 commandFromSpec :: CommandSpec a -> Command a
 763 commandFromSpec (CommandSpec ui action _) = action ui