Distribution/Simple/Command.hs

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

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.Simple.Command
    -- Copyright   :  Duncan Coutts 2007
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- 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 @cabal-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
                -> [get -> set -> OptDescr a]  -- ^MkOptDescr constructors partially
                                               -- applied to flags and description.
                -> OptionField a
    multiOption n get set args = OptionField n [arg get set | arg <- args]

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

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

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

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

    -- | (String -> a) variant of "optArg"
    optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)
               -> (b -> [Maybe String])
               -> MkOptDescr (a -> b) (b -> a -> a) a
    optArg' ad mkflag showflag =
        optArg ad (succeedReadE (mkflag . Just)) def showflag
          where def = mkflag Nothing

    noArg :: (Eq b) => 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

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

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

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

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

     where
        lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands'
                                    , cname' == cname ]
        noCommand        = CommandErrors ["no command given (try --help)\n"]
        badCommand cname = CommandErrors ["unrecognised command: " ++ cname
                                       ++ " (try --help)\n"]
        commands'      = commands ++ [commandAddAction helpCommandUI undefined]
        commandNames   = [ name | (Command name _ _ NormalCommand) <- commands' ]

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