-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Command
-- Copyright   :  Duncan Coutts 2007
--
-- 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@.

{- All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

module Distribution.Simple.Command (

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

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

  -- ** 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.HughesPJ    ( punctuate, cat, comma, text, empty)

data commandOptions :: ShowOrParseArgs -> [OptionField flags]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,
    -- | The useage line 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 datatype 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 datatype.
data optionDescr :: [OptDescr a]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 :: Name -> [OptDescr a] -> OptionField aOptionField n :: Stringn [arg :: MkOptDescr get set aarg sf :: SFlagssf lf :: LFlagslf d :: Descriptiond get :: getget set :: setset]
option _ _ _ _ _ _ = error :: [Char] -> aerror "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 :: Name -> [OptDescr a] -> OptionField aOptionField n :: Stringn [arg :: MkOptDescr get set aarg get :: getget set :: setset | arg <- args :: [get -> set -> OptDescr a]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 ::
  Description
  -> OptFlags
  -> ArgPlaceHolder
  -> ReadE (a -> a)
  -> (a -> [String])
  -> OptDescr aReqArg d :: Descriptiond (sf :: SFlagssf,lf :: LFlagslf) ad :: ArgPlaceHolderad (fmap :: Functor f => forall a b. (a -> b) -> f a -> f bfmap (\a b -> set :: setset (get :: getget b :: ab mappend :: Monoid a => a -> a -> a`mappend` a :: ba) b :: ab) mkflag :: String -> bmkflag) (showflag :: b -> [String]showflag (.) :: (b -> c) -> (a -> b) -> a -> c. get :: getget)

-- | 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 ::
  Description
  -> OptFlags
  -> ArgPlaceHolder
  -> ReadE (a -> a)
  -> (a -> a)
  -> (a -> [Maybe String])
  -> OptDescr aOptArg d :: Descriptiond (sf :: SFlagssf,lf :: LFlagslf) ad :: ArgPlaceHolderad (fmap :: Functor f => forall a b. (a -> b) -> f a -> f bfmap (\a b -> set :: setset (get :: getget b :: ab mappend :: Monoid a => a -> a -> a`mappend` a :: ba) b :: ab) mkflag :: String -> bmkflag)
               (\b ->          set :: setset (get :: getget b :: ab mappend :: Monoid a => a -> a -> a`mappend` def :: bdef) b :: ab)
               (showflag :: b -> [String]showflag (.) :: (b -> c) -> (a -> b) -> a -> c. get :: getget)

-- | (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 ::
  Monoid b =>
  ArgPlaceHolder
  -> ReadE b
  -> (b -> [String])
  -> MkOptDescr (a -> b) (b -> a -> a) areqArg ad :: ArgPlaceHolderad (succeedReadE :: (String -> a) -> ReadE asucceedReadE mkflag :: String -> bmkflag) showflag :: b -> [String]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 ::
  Monoid b =>
  ArgPlaceHolder
  -> ReadE b
  -> b
  -> (b -> [Maybe String])
  -> MkOptDescr (a -> b) (b -> a -> a) aoptArg ad :: ArgPlaceHolderad (succeedReadE :: (String -> a) -> ReadE asucceedReadE (mkflag :: String -> bmkflag (.) :: (b -> c) -> (a -> b) -> a -> c. Just :: a -> Maybe aJust)) def :: bdef showflag :: b -> [String]showflag
      where def = mkflag :: String -> bmkflag Nothing :: Maybe aNothing

noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a
noArg flag sf lf d = choiceOpt ::
  Eq b =>
  [(b, OptFlags, Description)] -> MkOptDescr (a -> b) (b -> a -> a) achoiceOpt [(flag :: bflag, (sf :: SFlagssf,lf :: LFlagslf), d :: Descriptiond)] sf :: SFlagssf lf :: LFlagslf d :: Descriptiond

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 ::
  Description
  -> OptFlags
  -> OptFlags
  -> (Bool -> a -> a)
  -> (a -> Maybe Bool)
  -> OptDescr aBoolOpt d :: Descriptiond (sfT :: SFlagssfT, ["enable-"(++) :: [a] -> [a] -> [a]++n :: Stringn]) (sfF :: SFlagssfF, ["disable-"(++) :: [a] -> [a] -> [a]++n :: Stringn]) (set :: setset(.) :: (b -> c) -> (a -> b) -> a -> c.s :: Bool -> bs) (g :: b -> Maybe Boolg(.) :: (b -> c) -> (a -> b) -> a -> c.get :: getget)
boolOpt _ _ _ _ _ _ _ _ _ = error :: [Char] -> aerror "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 ::
  Description
  -> OptFlags
  -> OptFlags
  -> (Bool -> a -> a)
  -> (a -> Maybe Bool)
  -> OptDescr aBoolOpt d :: Descriptiond ffT :: OptFlagsffT ffF :: OptFlagsffF (set :: setset(.) :: (b -> c) -> (a -> b) -> a -> c.s :: Bool -> bs) (g :: b -> Maybe Boolg (.) :: (b -> c) -> (a -> b) -> a -> c. get :: getget)

-- | 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 ::
  [(Description, OptFlags, a -> a, a -> Bool)] -> OptDescr aChoiceOpt alts :: [(Description, OptFlags, a -> a, a -> Bool)]alts
    where alts = [(d :: Descriptiond,flags :: aflags, set :: setset alt :: balt, ((==) :: Eq a => a -> a -> Bool==alt :: balt) (.) :: (b -> c) -> (a -> b) -> a -> c. get :: getget) | (alt,flags,d) <- aa_ff :: [(b, OptFlags, Description)]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 ::
  Eq b =>
  [(b, OptFlags, Description)] -> MkOptDescr (a -> b) (b -> a -> a) achoiceOpt [ (x :: ax, (sf :: SFlagssf, [map :: (a -> b) -> [a] -> [b]map toLower :: Char -> ChartoLower ($) :: (a -> b) -> a -> b$ show :: Show a => a -> Stringshow x :: ax]), d' :: [Char]d')
                                                | (x, sf) <- sflags' :: [(b, [Char])]sflags'
                                                , let d' = d :: Descriptiond (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow x :: ax]
                                            _sf :: SFlags_sf _lf :: LFlags_lf d :: Descriptiond get :: getget
    where sflags' = foldl :: (a -> b -> a) -> a -> [b] -> afoldl f :: a -> bf [] :: [a][] [firstOne :: bfirstOne..]
          f prev x = let prevflags = concatMap :: (a -> [b]) -> [a] -> [b]concatMap snd :: (a, b) -> bsnd prev :: [(a, [Char])]prev in
                     prev :: [(a, [Char])]prev (++) :: [a] -> [a] -> [a]++ take :: Int -> [a] -> [a]take 1 [(x :: ax, [toLower :: Char -> ChartoLower sf :: SFlagssf]) | sf <- show :: Show a => a -> Stringshow x :: ax, isAlpha :: Char -> BoolisAlpha sf :: SFlagssf
                                                       , toLower :: Char -> ChartoLower sf :: SFlagssf notElem :: Eq a => a -> [a] -> Bool`notElem` prevflags :: [Char]prevflags]
          firstOne = minBound :: Bounded a => aminBound asTypeOf :: a -> a -> a`asTypeOf` get :: getget undefined :: aundefined

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

viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]
viewAsGetOpt (OptionField _n aa) = concatMap :: (a -> [b]) -> [a] -> [b]concatMap optDescrToGetOpt :: OptDescr t -> [OptDescr (t -> t)]optDescrToGetOpt aa :: [OptDescr a]aa
  where
    optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =
         [Option :: [Char] -> [String] -> ArgDescr a -> String -> OptDescr aGetOpt.Option cs :: SFlagscs ss :: LFlagsss (ReqArg :: (String -> a) -> String -> ArgDescr aGetOpt.ReqArg set' :: Maybe String -> t -> tset' arg_desc :: ArgPlaceHolderarg_desc) d :: Descriptiond]
             where set' = readEOrFail :: ReadE a -> String -> areadEOrFail set :: setset
    optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) =
         [Option :: [Char] -> [String] -> ArgDescr a -> String -> OptDescr aGetOpt.Option cs :: SFlagscs ss :: LFlagsss (OptArg :: (Maybe String -> a) -> String -> ArgDescr aGetOpt.OptArg set' :: Maybe String -> t -> tset' arg_desc :: ArgPlaceHolderarg_desc) d :: Descriptiond]
             where set' Nothing    = def :: bdef
                   set' (Just txt) = readEOrFail :: ReadE a -> String -> areadEOrFail set :: setset txt :: Stringtxt
    optDescrToGetOpt (ChoiceOpt alts) =
         [Option :: [Char] -> [String] -> ArgDescr a -> String -> OptDescr aGetOpt.Option sf :: SFlagssf lf :: LFlagslf (NoArg :: a -> ArgDescr aGetOpt.NoArg set :: setset) d :: Descriptiond | (d,(sf,lf),set,_) <- alts :: [(Description, OptFlags, a -> a, a -> Bool)]alts ]
    optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =
         [ Option :: [Char] -> [String] -> ArgDescr a -> String -> OptDescr aGetOpt.Option sfT :: SFlagssfT lfT :: LFlagslfT (NoArg :: a -> ArgDescr aGetOpt.NoArg (set :: setset True :: BoolTrue))  ("Enable " (++) :: [a] -> [a] -> [a]++ d :: Descriptiond)
         , Option :: [Char] -> [String] -> ArgDescr a -> String -> OptDescr aGetOpt.Option sfF :: SFlagssfF lfF :: LFlagslfF (NoArg :: a -> ArgDescr aGetOpt.NoArg (set :: setset False :: BoolFalse)) ("Disable " (++) :: [a] -> [a] -> [a]++ d :: Descriptiond) ]

-- | 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 :: [Char] -> aerror "Distribution.command.viewAsFieldDescr: unexpected"
viewAsFieldDescr (OptionField n dd) = FieldDescr ::
  String
  -> (a -> Doc)
  -> (LineNo -> String -> a -> ParseResult a)
  -> FieldDescr aFieldDescr n :: Stringn get :: getget set :: setset
    where optDescr = head :: [a] -> ahead ($) :: (a -> b) -> a -> b$ sortBy :: (a -> a -> Ordering) -> [a] -> [a]sortBy cmp :: OptDescr t -> OptDescr t1 -> Orderingcmp dd :: [OptDescr a]dd
          ReqArg{}    `cmp` ReqArg{}    = EQ :: OrderingEQ
          ReqArg{}    `cmp` _           = GT :: OrderingGT
          BoolOpt{}   `cmp` ReqArg{}    = LT :: OrderingLT
          BoolOpt{}   `cmp` BoolOpt{}   = EQ :: OrderingEQ
          BoolOpt{}   `cmp` _           = GT :: OrderingGT
          ChoiceOpt{} `cmp` ReqArg{}    = LT :: OrderingLT
          ChoiceOpt{} `cmp` BoolOpt{}   = LT :: OrderingLT
          ChoiceOpt{} `cmp` ChoiceOpt{} = EQ :: OrderingEQ
          ChoiceOpt{} `cmp` _           = GT :: OrderingGT
          OptArg{}    `cmp` OptArg{}    = EQ :: OrderingEQ
          OptArg{}    `cmp` _           = LT :: OrderingLT
          get t = case optDescr :: OptDescr aoptDescr of
                    ReqArg _ _ _ _ ppr ->
                     (cat :: [Doc] -> Doccat (.) :: (b -> c) -> (a -> b) -> a -> c. punctuate :: Doc -> [Doc] -> [Doc]punctuate comma :: Doccomma (.) :: (b -> c) -> (a -> b) -> a -> c. map :: (a -> b) -> [a] -> [b]map text :: String -> Doctext (.) :: (b -> c) -> (a -> b) -> a -> c. ppr :: a -> [Maybe String]ppr) t :: at
                    OptArg _ _ _ _ _ ppr ->
                     case ppr :: a -> [Maybe String]ppr t :: at of
                        []        -> empty :: Docempty
                        (Nothing : _) -> text :: String -> Doctext "True"
                        (Just a  : _) -> text :: String -> Doctext a :: ba
                    ChoiceOpt alts ->
                     fromMaybe :: a -> Maybe a -> afromMaybe empty :: Docempty ($) :: (a -> b) -> a -> b$ listToMaybe :: [a] -> Maybe alistToMaybe
                         [ text :: String -> Doctext lf :: LFlagslf | (_,(_,lf:_), _,enabled) <- alts :: [(Description, OptFlags, a -> a, a -> Bool)]alts, enabled :: a -> Maybe Boolenabled t :: at]
                    BoolOpt _ _ _ _ enabled -> (maybe :: b -> (a -> b) -> Maybe a -> bmaybe empty :: Docempty disp :: Text a => a -> Docdisp (.) :: (b -> c) -> (a -> b) -> a -> c. enabled :: a -> Maybe Boolenabled) t :: at
          set line val a =
                  case optDescr :: OptDescr aoptDescr of
                    ReqArg _ _ _ readE _    -> (($) :: (a -> b) -> a -> b$ a :: ba) liftM :: Monad m => (a1 -> r) -> m a1 -> m r`liftM` runE :: LineNo -> String -> ReadE a -> String -> ParseResult arunE line :: LineNoline n :: Stringn readE :: ReadE (a -> a)readE val :: Stringval
                                             -- 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 b -> String -> Maybe (b -> b)getChoiceByLongFlag optDescr :: OptDescr aoptDescr val :: Stringval of
                                                 Just f -> return :: Monad m => forall a. a -> m areturn (f :: a -> bf a :: ba)
                                                 _      -> syntaxError :: LineNo -> String -> ParseResult asyntaxError line :: LineNoline val :: Stringval
                    BoolOpt _ _ _ setV _    -> (setV :: Bool -> a -> a`setV` a :: ba) liftM :: Monad m => (a1 -> r) -> m a1 -> m r`liftM` runP :: LineNo -> String -> ReadP a a -> String -> ParseResult arunP line :: LineNoline n :: Stringn parse :: Text a => forall r. ReadP r aparse val :: Stringval
                    OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far,
                                               -- so we avoid future surprises by not implementing it.
                                               error :: [Char] -> aerror "Command.optionToFieldDescr: feature not implemented"

getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)
getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe :: [a] -> Maybe alistToMaybe [ set :: setset | (_,(_sf,lf:_), set, _) <- alts :: [(Description, OptFlags, a -> a, a -> Bool)]alts
                                                             , lf :: LFlagslf (==) :: Eq a => a -> a -> Bool== val :: Stringval]

getChoiceByLongFlag _ _ = error :: [Char] -> aerror "Distribution.command.getChoiceByLongFlag: expected a choice option"

getCurrentChoice :: OptDescr a -> a -> [String]
getCurrentChoice (ChoiceOpt alts) a =
    [ lf :: LFlagslf | (_,(_sf,lf:_), _, currentChoice) <- alts :: [(Description, OptFlags, a -> a, a -> Bool)]alts, currentChoice :: a -> BoolcurrentChoice a :: ba]

getCurrentChoice _ _ = error :: [Char] -> aerror "Command.getChoice: expected a Choice OptDescr"


liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
liftOption get' set' opt = opt :: [Char]opt { optionDescr = liftOptDescr ::
  (b -> a) -> (a -> b -> b) -> OptDescr a -> OptDescr bliftOptDescr get' :: b -> aget' set' :: Maybe String -> t -> tset' map :: (a -> b) -> [a] -> [b]`map` optionDescr :: OptionField a -> [OptDescr a]optionDescr opt :: [Char]opt}


liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
liftOptDescr get' set' (ChoiceOpt opts) =
    ChoiceOpt ::
  [(Description, OptFlags, a -> a, a -> Bool)] -> OptDescr aChoiceOpt [ (d :: Descriptiond, ff :: OptFlagsff, liftSet :: (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> bliftSet get' :: b -> aget' set' :: Maybe String -> t -> tset' set :: setset , (get :: getget (.) :: (b -> c) -> (a -> b) -> a -> c. get' :: b -> aget'))
              | (d, ff, set, get) <- opts :: [String]opts]

liftOptDescr get' set' (OptArg d ff ad set def get) =
    OptArg ::
  Description
  -> OptFlags
  -> ArgPlaceHolder
  -> ReadE (a -> a)
  -> (a -> a)
  -> (a -> [Maybe String])
  -> OptDescr aOptArg d :: Descriptiond ff :: OptFlagsff ad :: ArgPlaceHolderad (liftSet :: (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> bliftSet get' :: b -> aget' set' :: Maybe String -> t -> tset' fmap :: Functor f => forall a b. (a -> b) -> f a -> f b`fmap` set :: setset) (liftSet :: (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> bliftSet get' :: b -> aget' set' :: Maybe String -> t -> tset' def :: bdef) (get :: getget (.) :: (b -> c) -> (a -> b) -> a -> c. get' :: b -> aget')

liftOptDescr get' set' (ReqArg d ff ad set get) =
    ReqArg ::
  Description
  -> OptFlags
  -> ArgPlaceHolder
  -> ReadE (a -> a)
  -> (a -> [String])
  -> OptDescr aReqArg d :: Descriptiond ff :: OptFlagsff ad :: ArgPlaceHolderad (liftSet :: (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> bliftSet get' :: b -> aget' set' :: Maybe String -> t -> tset' fmap :: Functor f => forall a b. (a -> b) -> f a -> f b`fmap` set :: setset) (get :: getget (.) :: (b -> c) -> (a -> b) -> a -> c. get' :: b -> aget')

liftOptDescr get' set' (BoolOpt d ffT ffF set get) =
    BoolOpt ::
  Description
  -> OptFlags
  -> OptFlags
  -> (Bool -> a -> a)
  -> (a -> Maybe Bool)
  -> OptDescr aBoolOpt d :: Descriptiond ffT :: OptFlagsffT ffF :: OptFlagsffF (liftSet :: (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> bliftSet get' :: b -> aget' set' :: Maybe String -> t -> tset' (.) :: (b -> c) -> (a -> b) -> a -> c. set :: setset) (get :: getget (.) :: (b -> c) -> (a -> b) -> a -> c. get' :: b -> aget')

liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b
liftSet get' set' set x = set' :: Maybe String -> t -> tset' (set :: setset ($) :: (a -> b) -> a -> b$ get' :: b -> aget' x :: ax) x :: ax

-- | Show flags in the standard long option command line format
commandShowOptions :: CommandUI flags -> flags -> [String]
commandShowOptions command v = concat :: [[a]] -> [a]concat
  [ showOptDescr :: a -> OptDescr a -> [String]showOptDescr v :: flagsv  od :: OptDescr flagsod | o <- commandOptions ::
  CommandUI flags -> ShowOrParseArgs -> [OptionField flags]commandOptions command :: CommandUI flagscommand ParseArgs :: ShowOrParseArgsParseArgs
                       , od <- optionDescr :: OptionField a -> [OptDescr a]optionDescr o :: OptionField flagso]
  where
    showOptDescr :: a -> OptDescr a -> [String]
    showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled)
      = case enabled :: a -> Maybe Boolenabled x :: ax of
          Nothing -> [] :: [a][]
          Just True  -> ["--" (++) :: [a] -> [a] -> [a]++ lfT :: LFlagslfT]
          Just False -> ["--" (++) :: [a] -> [a] -> [a]++ lfF :: LFlagslfF]
    showOptDescr x c@ChoiceOpt{}
      = ["--" (++) :: [a] -> [a] -> [a]++ val :: Stringval | val <- getCurrentChoice :: OptDescr a -> a -> [String]getCurrentChoice c :: OptDescr ac x :: ax]
    showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)
      = [ "--"(++) :: [a] -> [a] -> [a]++lf :: LFlagslf(++) :: [a] -> [a] -> [a]++"="(++) :: [a] -> [a] -> [a]++flag :: bflag
        | flag <- showflag :: b -> [String]showflag x :: ax ]
    showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag)
      = [ case flag :: bflag of
            Just s  -> "--"(++) :: [a] -> [a] -> [a]++lf :: LFlagslf(++) :: [a] -> [a] -> [a]++"="(++) :: [a] -> [a] -> [a]++s :: Bool -> bs
            Nothing -> "--"(++) :: [a] -> [a] -> [a]++lf :: LFlagslf
        | flag <- showflag :: b -> [String]showflag x :: ax ]
    showOptDescr _ _
      = error :: [Char] -> aerror "Distribution.Simple.Command.showOptDescr: unreachable"


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

-- | The help text for this command with descriptions of all the options.
commandHelp :: CommandUI flags -> String -> String
commandHelp command pname =
    commandUsage :: CommandUI flags -> String -> StringcommandUsage command :: CommandUI flagscommand pname :: Stringpname
 (++) :: [a] -> [a] -> [a]++ (usageInfo :: String -> [OptDescr a] -> StringGetOpt.usageInfo ""
  (.) :: (b -> c) -> (a -> b) -> a -> c. addCommonFlags ::
  ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]addCommonFlags ShowArgs :: ShowOrParseArgsShowArgs
  ($) :: (a -> b) -> a -> b$ commandGetOpts ::
  ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]commandGetOpts ShowArgs :: ShowOrParseArgsShowArgs command :: CommandUI flagscommand)
 (++) :: [a] -> [a] -> [a]++ case commandDescription :: CommandUI flags -> Maybe (String -> String)commandDescription command :: CommandUI flagscommand of
      Nothing   -> ""
      Just desc -> '\n'(:) :: a -> [a] -> [a]: desc :: String -> Stringdesc pname :: Stringpname

-- | 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 :: Stringname,
    commandSynopsis     = shortDesc :: StringshortDesc,
    commandDescription  = longDesc :: Maybe (String -> String)longDesc,
    commandUsage        = usage :: [Char] -> [Char]usage,
    commandDefaultFlags = defaultFlags :: flagsdefaultFlags,
    commandOptions      = options :: [OptDescr (Either CommonFlag (flags -> flags))]options
  }
  where usage pname = "Usage: " (++) :: [a] -> [a] -> [a]++ pname :: Stringpname (++) :: [a] -> [a] -> [a]++ " " (++) :: [a] -> [a] -> [a]++ name :: Stringname (++) :: [a] -> [a] -> [a]++ " [FLAGS]\n\n"
                   (++) :: [a] -> [a] -> [a]++ "Flags for " (++) :: [a] -> [a] -> [a]++ name :: Stringname (++) :: [a] -> [a] -> [a]++ ":"

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

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

addCommonFlags :: ShowOrParseArgs
               -> [GetOpt.OptDescr a]
               -> [GetOpt.OptDescr (Either CommonFlag a)]
addCommonFlags showOrParseArgs options =
     map :: (a -> b) -> [a] -> [b]map (fmapOptDesc :: (b -> a) -> OptDescr b -> OptDescr afmapOptDesc Left :: a -> Either a bLeft)  (commonFlags :: ShowOrParseArgs -> [OptDescr CommonFlag]commonFlags showOrParseArgs :: ShowOrParseArgsshowOrParseArgs)
  (++) :: [a] -> [a] -> [a]++ map :: (a -> b) -> [a] -> [b]map (fmapOptDesc :: (b -> a) -> OptDescr b -> OptDescr afmapOptDesc Right :: b -> Either a bRight) options :: [OptDescr (Either CommonFlag (flags -> flags))]options
  where fmapOptDesc f (GetOpt.Option s l d m) =
                       Option :: [Char] -> [String] -> ArgDescr a -> String -> OptDescr aGetOpt.Option s :: Bool -> bs l :: [String]l (fmapArgDesc :: (b -> a) -> ArgDescr b -> ArgDescr afmapArgDesc f :: a -> bf d :: Descriptiond) m :: Stringm
        fmapArgDesc f (GetOpt.NoArg a)    = NoArg :: a -> ArgDescr aGetOpt.NoArg (f :: a -> bf a :: ba)
        fmapArgDesc f (GetOpt.ReqArg s d) = ReqArg :: (String -> a) -> String -> ArgDescr aGetOpt.ReqArg (f :: a -> bf (.) :: (b -> c) -> (a -> b) -> a -> c. s :: Bool -> bs) d :: Descriptiond
        fmapArgDesc f (GetOpt.OptArg s d) = OptArg :: (Maybe String -> a) -> String -> ArgDescr aGetOpt.OptArg (f :: a -> bf (.) :: (b -> c) -> (a -> b) -> a -> c. s :: Bool -> bs) d :: Descriptiond

-- | 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 ::
  ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]addCommonFlags ParseArgs :: ShowOrParseArgsParseArgs
              ($) :: (a -> b) -> a -> b$ commandGetOpts ::
  ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]commandGetOpts ParseArgs :: ShowOrParseArgsParseArgs command :: CommandUI flagscommand
      order | global :: Boolglobal    = RequireOrder :: ArgOrder aGetOpt.RequireOrder
            | otherwise :: Boolotherwise = Permute :: ArgOrder aGetOpt.Permute
  in case getOpt' ::
  ArgOrder a
  -> [OptDescr a]
  -> [String]
  -> ([a], [String], [String], [String])GetOpt.getOpt' order :: ArgOrder aorder options :: [OptDescr (Either CommonFlag (flags -> flags))]options args :: [get -> set -> OptDescr a]args of
    (flags, _, _,  _)
      | any :: (a -> Bool) -> [a] -> Boolany listFlag :: Either CommonFlag t -> BoollistFlag flags :: aflags -> CommandList :: [String] -> CommandParse flagsCommandList (commandListOptions :: CommandUI flags -> [String]commandListOptions command :: CommandUI flagscommand)
      | any :: (a -> Bool) -> [a] -> Boolany helpFlag :: Either CommonFlag t -> BoolhelpFlag flags :: aflags -> CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp (commandHelp :: CommandUI flags -> String -> StringcommandHelp command :: CommandUI flagscommand)
      where listFlag (Left ListOptionsFlag) = True :: BoolTrue; listFlag _ = False :: BoolFalse
            helpFlag (Left HelpFlag)        = True :: BoolTrue; helpFlag _ = False :: BoolFalse
    (flags, opts, opts', [])
      | global :: Boolglobal (||) :: Bool -> Bool -> Bool|| null :: [a] -> Boolnull opts' :: [String]opts' -> CommandReadyToGo :: flags -> CommandParse flagsCommandReadyToGo (accum :: [Either t (c -> c)] -> c -> caccum flags :: aflags, mix :: [a] -> [a] -> [a]mix opts :: [String]opts opts' :: [String]opts')
      | otherwise :: Boolotherwise            -> CommandErrors :: [String] -> CommandParse flagsCommandErrors (unrecognised :: [[Char]] -> [[Char]]unrecognised opts' :: [String]opts')
    (_, _, _, errs)          -> CommandErrors :: [String] -> CommandParse flagsCommandErrors errs :: [String]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 compsition is right to left.
        accum flags = foldr :: (a -> b -> b) -> b -> [a] -> bfoldr (flip :: (a -> b -> c) -> b -> a -> cflip (.) :: (b -> c) -> (a -> b) -> a -> c(.)) id :: a -> aid [ f :: a -> bf | Right f <- flags :: aflags ]
        unrecognised opts = [ "unrecognized option `" (++) :: [a] -> [a] -> [a]++ opt :: [Char]opt (++) :: [a] -> [a] -> [a]++ "'\n"
                            | opt <- opts :: [String]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 :: [a]ys
        mix (x:xs) ys = x :: ax(:) :: a -> [a] -> [a]:ys :: [a]ys(++) :: [a] -> [a] -> [a]++xs :: [a]xs

data CommandParse flags = CommandHelp (String -> String)
                        | CommandList [String]
                        | CommandErrors [String]
                        | CommandReadyToGo flags
instance D:Functor ::
  (forall a b. (a -> b) -> f a -> f b)
  -> (forall a b. a -> f b -> f a)
  -> T:Functor fFunctor CommandParse where
  fmap _ (CommandHelp help)       = CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp help :: String -> Stringhelp
  fmap _ (CommandList opts)       = CommandList :: [String] -> CommandParse flagsCommandList opts :: [String]opts
  fmap _ (CommandErrors errs)     = CommandErrors :: [String] -> CommandParse flagsCommandErrors errs :: [String]errs
  fmap f (CommandReadyToGo flags) = CommandReadyToGo :: flags -> CommandParse flagsCommandReadyToGo (f :: a -> bf flags :: aflags)


data Command action = Command String String ([String] -> CommandParse action)

commandAddAction :: CommandUI flags
                 -> (flags -> [String] -> action)
                 -> Command action
commandAddAction command action =
  Command ::
  String
  -> String
  -> ([String] -> CommandParse action)
  -> Command actionCommand (commandName :: CommandUI flags -> StringcommandName command :: CommandUI flagscommand)
          (commandSynopsis :: CommandUI flags -> StringcommandSynopsis command :: CommandUI flagscommand)
          (fmap :: Functor f => forall a b. (a -> b) -> f a -> f bfmap (uncurry :: (a -> b -> c) -> (a, b) -> cuncurry applyDefaultArgs :: (flags -> flags) -> [String] -> actionapplyDefaultArgs)
         (.) :: (b -> c) -> (a -> b) -> a -> c. commandParseArgs ::
  CommandUI flags
  -> Bool
  -> [String]
  -> CommandParse (flags -> flags, [String])commandParseArgs command :: CommandUI flagscommand False :: BoolFalse)

  where applyDefaultArgs mkflags args =
          let flags = mkflags :: a -> amkflags (commandDefaultFlags :: CommandUI flags -> flagscommandDefaultFlags command :: CommandUI flagscommand)
           in action :: [String] -> CommandParse actionaction flags :: aflags args :: [get -> set -> OptDescr a]args

commandsRun :: CommandUI a
            -> [Command action]
            -> [String]
            -> CommandParse (a, CommandParse action)
commandsRun globalCommand commands args =
  case commandParseArgs ::
  CommandUI flags
  -> Bool
  -> [String]
  -> CommandParse (flags -> flags, [String])commandParseArgs globalCommand' :: CommandUI aglobalCommand' True :: BoolTrue args :: [get -> set -> OptDescr a]args of
    CommandHelp      help          -> CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp help :: String -> Stringhelp
    CommandList      opts          -> CommandList :: [String] -> CommandParse flagsCommandList (opts :: [String]opts (++) :: [a] -> [a] -> [a]++ commandNames :: [String]commandNames)
    CommandErrors    errs          -> CommandErrors :: [String] -> CommandParse flagsCommandErrors errs :: [String]errs
    CommandReadyToGo (mkflags, args') -> case args' :: [String]args' of
      ("help":cmdArgs) -> handleHelpCommand :: [String] -> CommandParse flagshandleHelpCommand cmdArgs :: [String]cmdArgs
      (name:cmdArgs) -> case lookupCommand :: String -> [Command action]lookupCommand name :: Stringname of
        [Command _ _ action] -> CommandReadyToGo :: flags -> CommandParse flagsCommandReadyToGo (flags :: aflags, action :: [String] -> CommandParse actionaction cmdArgs :: [String]cmdArgs)
        _                    -> CommandReadyToGo :: flags -> CommandParse flagsCommandReadyToGo (flags :: aflags, badCommand :: [Char] -> CommandParse flagsbadCommand name :: Stringname)
      []                     -> CommandReadyToGo :: flags -> CommandParse flagsCommandReadyToGo (flags :: aflags, noCommand :: CommandParse flagsnoCommand)
     where flags = mkflags :: a -> amkflags (commandDefaultFlags :: CommandUI flags -> flagscommandDefaultFlags globalCommand :: CommandUI aglobalCommand)

 where
    lookupCommand cname = [ cmd :: Command actioncmd | cmd@(Command cname' _ _) <- commands' :: [Command action]commands'
                          , cname' :: Stringcname'(==) :: Eq a => a -> a -> Bool==cname :: Stringcname ]
    noCommand        = CommandErrors :: [String] -> CommandParse flagsCommandErrors ["no command given (try --help)\n"]
    badCommand cname = CommandErrors :: [String] -> CommandParse flagsCommandErrors ["unrecognised command: " (++) :: [a] -> [a] -> [a]++ cname :: Stringcname
                                   (++) :: [a] -> [a] -> [a]++ " (try --help)\n"]
    commands'      = commands :: [Command action]commands (++) :: [a] -> [a] -> [a]++ [commandAddAction ::
  CommandUI flags -> (flags -> [String] -> action) -> Command actioncommandAddAction helpCommandUI :: CommandUI ()helpCommandUI undefined :: aundefined]
    commandNames   = [ name :: Stringname | Command name _ _ <- commands' :: [Command action]commands' ]
    globalCommand' = globalCommand :: CommandUI aglobalCommand {
      commandUsage = \pname ->
           (case commandUsage :: CommandUI flags -> String -> StringcommandUsage globalCommand :: CommandUI aglobalCommand pname :: Stringpname of
             ""       -> ""
             original -> original :: Stringoriginal (++) :: [a] -> [a] -> [a]++ "\n")
        (++) :: [a] -> [a] -> [a]++ "Usage: " (++) :: [a] -> [a] -> [a]++ pname :: Stringpname (++) :: [a] -> [a] -> [a]++ " COMMAND [FLAGS]\n"
        (++) :: [a] -> [a] -> [a]++ "   or: " (++) :: [a] -> [a] -> [a]++ pname :: Stringpname (++) :: [a] -> [a] -> [a]++ " [GLOBAL FLAGS]\n\n"
        (++) :: [a] -> [a] -> [a]++ "Global flags:",
      commandDescription = Just :: a -> Maybe aJust ($) :: (a -> b) -> a -> b$ \pname ->
           "Commands:\n"
        (++) :: [a] -> [a] -> [a]++ unlines :: [String] -> Stringunlines [ "  " (++) :: [a] -> [a] -> [a]++ align :: [Char] -> [Char]align name :: Stringname (++) :: [a] -> [a] -> [a]++ "    " (++) :: [a] -> [a] -> [a]++ description :: Stringdescription
                   | Command name description _ <- commands' :: [Command action]commands' ]
        (++) :: [a] -> [a] -> [a]++ case commandDescription :: CommandUI flags -> Maybe (String -> String)commandDescription globalCommand :: CommandUI aglobalCommand of
             Nothing   -> ""
             Just desc -> '\n'(:) :: a -> [a] -> [a]: desc :: String -> Stringdesc pname :: Stringpname
    }
      where maxlen = maximum :: Ord a => [a] -> amaximum [ length :: [a] -> Intlength name :: Stringname | Command name _ _ <- commands' :: [Command action]commands' ]
            align str = str :: [Char]str (++) :: [a] -> [a] -> [a]++ replicate :: Int -> a -> [a]replicate (maxlen :: Intmaxlen (-) :: Num a => a -> a -> a- length :: [a] -> Intlength str :: [Char]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 ::
  CommandUI flags
  -> Bool
  -> [String]
  -> CommandParse (flags -> flags, [String])commandParseArgs helpCommandUI :: CommandUI ()helpCommandUI True :: BoolTrue cmdArgs :: [String]cmdArgs of
        CommandHelp      help    -> CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp help :: String -> Stringhelp
        CommandList      list    -> CommandList :: [String] -> CommandParse flagsCommandList (list :: [String]list (++) :: [a] -> [a] -> [a]++ commandNames :: [String]commandNames)
        CommandErrors    _       -> CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp globalHelp :: String -> StringglobalHelp
        CommandReadyToGo (_,[])  -> CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp globalHelp :: String -> StringglobalHelp
        CommandReadyToGo (_,(name:cmdArgs')) ->
          case lookupCommand :: String -> [Command action]lookupCommand name :: Stringname of
            [Command _ _ action] ->
              case action :: [String] -> CommandParse actionaction ("--help"(:) :: a -> [a] -> [a]:cmdArgs' :: [String]cmdArgs') of
                CommandHelp help -> CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp help :: String -> Stringhelp
                CommandList _    -> CommandList :: [String] -> CommandParse flagsCommandList [] :: [a][]
                _                -> CommandHelp :: (String -> String) -> CommandParse flagsCommandHelp globalHelp :: String -> StringglobalHelp
            _                    -> badCommand :: [Char] -> CommandParse flagsbadCommand name :: Stringname

     where globalHelp = commandHelp :: CommandUI flags -> String -> StringcommandHelp globalCommand' :: CommandUI aglobalCommand'
    helpCommandUI =
      (makeCommand ::
  String
  -> String
  -> Maybe (String -> String)
  -> flags
  -> (ShowOrParseArgs -> [OptionField flags])
  -> CommandUI flagsmakeCommand "help" "Help about commands" Nothing :: Maybe aNothing () (const :: a -> b -> aconst [] :: [a][])) {
        commandUsage = \pname ->
             "Usage: " (++) :: [a] -> [a] -> [a]++ pname :: Stringpname (++) :: [a] -> [a] -> [a]++ " help [FLAGS]\n"
          (++) :: [a] -> [a] -> [a]++ "   or: " (++) :: [a] -> [a] -> [a]++ pname :: Stringpname (++) :: [a] -> [a] -> [a]++ " help COMMAND [FLAGS]\n\n"
          (++) :: [a] -> [a] -> [a]++ "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 :: Monad m => forall a. a -> m areturn ()
noExtraFlags extraFlags =
  die :: String -> IO adie ($) :: (a -> b) -> a -> b$ "Unrecognised flags: " (++) :: [a] -> [a] -> [a]++ intercalate :: [a] -> [[a]] -> [a]intercalate ", " extraFlags :: [String]extraFlags
--TODO: eliminate this function and turn it into a variant on commandAddAction
--      instead like commandAddActionNoArgs that doesn't supply the [String]