# LANGUAGE ExistentialQuantification #
# LANGUAGE FlexibleContexts #
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Command
  Copyright    :     2007
-- License     :  BSD3
--
-- Maintainer  :  
-- Portability :  non-portable (ExistentialQuantification)
--
  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  - install@.

module Distribution.Simple.Command (

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

  -- ** Constructing commands
  ShowOrParseArgs(..),
  usageDefault,
  usageAlternatives,
  mkCommandUI,
  hiddenCommand,

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

  -- ** Building lists of commands
  CommandType(..),
  CommandSpec(..),
  commandFromSpec,

  -- ** Running commands
  commandsRun,

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

-- ** Constructing Option Fields
  option, multiOption,

  * * Liftings & Projections
  liftOption, liftOptionL,

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

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

  ) where

import Prelude ()
import Distribution.Compat.Prelude hiding (get)

import qualified Distribution.GetOpt as GetOpt
import Distribution.ReadE
import Distribution.Simple.Utils
import Distribution.Compat.Lens (ALens', (^#), (#~))


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),
    -- | Post-Usage notes and examples in help texts
    commandNotes :: 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
  ^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) => 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) ]

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}

-- | @since 3.4.0.0
liftOptionL :: ALens' b a -> OptionField a -> OptionField b
liftOptionL l = liftOption (^# l) (l #~)


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 =
    commandSynopsis command
 ++ "\n\n"
 ++ commandUsage command pname
 ++ ( case commandDescription command of
        Nothing   -> ""
        Just desc -> '\n': desc pname)
 ++ "\n"
 ++ ( if cname == ""
        then "Global flags:"
        else "Flags for " ++ cname ++ ":" )
 ++ ( GetOpt.usageInfo ""
    . addCommonFlags ShowArgs
    $ commandGetOpts ShowArgs command )
 ++ ( case commandNotes command of
        Nothing   -> ""
        Just notes -> '\n': notes pname)
  where cname = commandName command

-- | Default "usage" documentation text for commands.
usageDefault :: String -> String -> String
usageDefault name pname =
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
  ++ "Flags for " ++ name ++ ":"

-- | Create "usage" documentation from a list of parameter
--   configurations.
usageAlternatives :: String -> [String] -> String -> String
usageAlternatives name strs pname = unlines
  [ start ++ pname ++ " " ++ name ++ " " ++ s
  | let starts = "Usage: " : repeat "   or: "
  , (start, s) <- zip starts strs
  ]

  | Make a Command from standard ' GetOpt ' options .
mkCommandUI :: String          -- ^ name
            -> String          -- ^ synopsis
            -> [String]        -- ^ usage alternatives
            -> flags           -- ^ initial\/empty flags
            -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options
            -> CommandUI flags
mkCommandUI name synopsis usages flags options = CommandUI
  { commandName         = name
  , commandSynopsis     = synopsis
  , commandDescription  = Nothing
  , commandNotes        = Nothing
  , commandUsage        = usageAlternatives name usages
  , commandDefaultFlags = flags
  , commandOptions      = options
  }

-- | 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

  |  command as hidden . Hidden commands do n'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' ]

    -- 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

-- | 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 =
  dieNoVerbosity $ "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]

-- | Helper function for creating globalCommand description
getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions cmds =
  [ (name, description)
  | Command name description _ NormalCommand <- cmds ]

helpCommandUI :: CommandUI ()
helpCommandUI =
  (mkCommandUI
    "help"
    "Help about commands."
    ["[FLAGS]", "COMMAND [FLAGS]"]
    ()
    (const []))
  {
    commandNotes = Just $ \pname ->
       "Examples:\n"
    ++ "  " ++ pname ++ " help help\n"
    ++ "    Oh, appararently you already know this.\n"
  }

  | wraps a @CommandUI@ together with a function that turns it into a @Command@.
-- By hiding the type of flags for the UI allows construction of a list of all UIs at the
-- top level of the program. That list can then be used for generation of manual page
-- as well as for executing the selected command.
data CommandSpec action
  = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType

commandFromSpec :: CommandSpec a -> Command a
commandFromSpec (CommandSpec ui action _) = action ui

# LANGUAGE RankNTypes #
---------------------------------------------------------------------------
 |
 Module      :  Distribution.Simple.Command
 License     :  BSD3

 Maintainer  :  
 Portability :  non-portable (ExistentialQuantification)

 organised into a number of named sub-commands (much like darcs). The
 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
 * Command interface
 ** Constructing commands
 ** Associating actions with commands
 ** Building lists of commands
 ** Running commands
 * Option Fields
 ** Constructing Option Fields
 * Option Descriptions
 | The name of the command as it would be entered on the command line.
 For example @\"build\"@.
 | A function that maps a program name to a usage summary for this
 command.
 | Additional explanation of the command to use in help texts.
 | Post-Usage notes and examples in help texts
 | All the Option fields for this command
 | 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.
 interface for the field.
True
False
 | Short command line option strings
 | Long command line option strings
   You will have to give the flags and description individually to the
 applied to flags and description.
 | Create a string-valued command line interface.
 | Create a string-valued command line interface with a default value.
 | (String -> a) variant of "reqArg"
 | create a Choice option
   which does not conflict with a previous one is used.
 | @since 3.4.0.0
 | Show flags in the standard long option command line format
 This is a slight hack, we don't want
 "--list-options" showing up in the
 | The help text for this command with descriptions of all the options.
 | Default "usage" documentation text for commands.
 | Create "usage" documentation from a list of parameter
   configurations.
 ^ name
 ^ synopsis
 ^ usage alternatives
 ^ initial\/empty flags
 ^ options
 | Common flags that apply to every command
 | Parse a bunch of command line arguments

 ^ Is the command a global or subcommand?
 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.
 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.
 help' or 'progname --help' output.
 A bit of a hack: support "prog help" as a synonym of "prog --help"
 furthermore, support "prog help command" as "prog command --help"
 | Utility function, many commands do not accept additional flags. This
 action fails with a helpful error message if the user supplies any extra.

TODO: eliminate this function and turn it into a variant on commandAddAction
      instead like commandAddActionNoArgs that doesn't supply the [String]
 | Helper function for creating globalCommand description
 By hiding the type of flags for the UI allows construction of a list of all UIs at the
 top level of the program. That list can then be used for generation of manual page
 as well as for executing the selected command.
# LANGUAGE ExistentialQuantification #
# LANGUAGE FlexibleContexts #

  Copyright    :     2007
  This is to do with command line handling . The Cabal command line is
  ' CommandUI ' abstraction represents one of these sub - commands , with a name ,
  derived commands . This feature is used heavily in  - install@.

module Distribution.Simple.Command (

  CommandUI(..),
  commandShowOptions,
  CommandParse(..),
  commandParseArgs,
  getNormalCommandDescriptions,
  helpCommandUI,

  ShowOrParseArgs(..),
  usageDefault,
  usageAlternatives,
  mkCommandUI,
  hiddenCommand,

  Command,
  commandAddAction,
  noExtraFlags,

  CommandType(..),
  CommandSpec(..),
  commandFromSpec,

  commandsRun,

  OptionField(..), Name,

  option, multiOption,

  * * Liftings & Projections
  liftOption, liftOptionL,

  OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,

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

  ) where

import Prelude ()
import Distribution.Compat.Prelude hiding (get)

import qualified Distribution.GetOpt as GetOpt
import Distribution.ReadE
import Distribution.Simple.Utils
import Distribution.Compat.Lens (ALens', (^#), (#~))


data CommandUI flags = CommandUI {
    commandName        :: String,
  | A short , one line description of the command to use in help texts .
    commandSynopsis :: String,
    commandUsage    :: String -> String,
    commandDescription :: Maybe (String -> String),
    commandNotes :: Maybe (String -> String),
  | Initial \/ empty flags
    commandDefaultFlags :: flags,
    commandOptions     :: ShowOrParseArgs -> [OptionField flags]
  }

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

data OptionField a = OptionField {
  optionName        :: Name,
  optionDescr       :: [OptDescr a] }

  | An OptionField takes one or more OptDescrs , describing the command line
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)]

                   (Bool -> a -> a) (a-> Maybe Bool)

type SFlags   = [Char]
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 .
    OptDescr constructor .
multiOption :: Name -> get -> set
  ^MkOptDescr constructors partially
            -> 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

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)

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)

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) => 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)

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
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) ]

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}

liftOptionL :: ALens' b a -> OptionField a -> OptionField b
liftOptionL l = liftOption (^# l) (l #~)


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

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 $
  list options output , so use ShowArgs
      commandGetOpts ShowArgs command
  where
    listOption (GetOpt.Option shortNames longNames _ _) =
         [ "-"  ++ [name] | name <- shortNames ]
      ++ [ "--" ++  name  | name <- longNames ]

commandHelp :: CommandUI flags -> String -> String
commandHelp command pname =
    commandSynopsis command
 ++ "\n\n"
 ++ commandUsage command pname
 ++ ( case commandDescription command of
        Nothing   -> ""
        Just desc -> '\n': desc pname)
 ++ "\n"
 ++ ( if cname == ""
        then "Global flags:"
        else "Flags for " ++ cname ++ ":" )
 ++ ( GetOpt.usageInfo ""
    . addCommonFlags ShowArgs
    $ commandGetOpts ShowArgs command )
 ++ ( case commandNotes command of
        Nothing   -> ""
        Just notes -> '\n': notes pname)
  where cname = commandName command

usageDefault :: String -> String -> String
usageDefault name pname =
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
  ++ "Flags for " ++ name ++ ":"

usageAlternatives :: String -> [String] -> String -> String
usageAlternatives name strs pname = unlines
  [ start ++ pname ++ " " ++ name ++ " " ++ s
  | let starts = "Usage: " : repeat "   or: "
  , (start, s) <- zip starts strs
  ]

  | Make a Command from standard ' GetOpt ' options .
            -> CommandUI flags
mkCommandUI name synopsis usages flags options = CommandUI
  { commandName         = name
  , commandSynopsis     = synopsis
  , commandDescription  = Nothing
  , commandNotes        = Nothing
  , commandUsage        = usageAlternatives name usages
  , commandDefaultFlags = flags
  , commandOptions      = options
  }

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

commandParseArgs :: CommandUI flags
                 -> [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

        accum flags = foldr (flip (.)) id [ f | Right f <- flags ]
        unrecognised opts = [ "unrecognized "
                              ++ "'" ++ (commandName command) ++ "'"
                              ++ " option `" ++ opt ++ "'\n"
                            | opt <- opts ]
        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

  |  command as hidden . Hidden commands do n't show up in the ' progname
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' ]

    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

noExtraFlags :: [String] -> IO ()
noExtraFlags [] = return ()
noExtraFlags extraFlags =
  dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags

getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions cmds =
  [ (name, description)
  | Command name description _ NormalCommand <- cmds ]

helpCommandUI :: CommandUI ()
helpCommandUI =
  (mkCommandUI
    "help"
    "Help about commands."
    ["[FLAGS]", "COMMAND [FLAGS]"]
    ()
    (const []))
  {
    commandNotes = Just $ \pname ->
       "Examples:\n"
    ++ "  " ++ pname ++ " help help\n"
    ++ "    Oh, appararently you already know this.\n"
  }

  | wraps a @CommandUI@ together with a function that turns it into a @Command@.
data CommandSpec action
  = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType

commandFromSpec :: CommandSpec a -> Command a
commandFromSpec (CommandSpec ui action _) = action ui
