1{-# LANGUAGE ExistentialQuantification #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE RankNTypes #-} 4 5----------------------------------------------------------------------------- 6-- | 7-- Module : Distribution.Simple.Command 8-- Copyright : Duncan Coutts 2007 9-- License : BSD3 10-- 11-- Maintainer : cabal-devel@haskell.org 12-- Portability : non-portable (ExistentialQuantification) 13-- 14-- This is to do with command line handling. The Cabal command line is 15-- organised into a number of named sub-commands (much like darcs). The 16-- 'CommandUI' abstraction represents one of these sub-commands, with a name, 17-- description, a set of flags. Commands can be associated with actions and 18-- run. It handles some common stuff automatically, like the @--help@ and 19-- command line completion flags. It is designed to allow other tools make 20-- derived commands. This feature is used heavily in @cabal-install@. 21 22module Distribution.Simple.Command ( 23 24 -- * Command interface 25 CommandUI(..), 26 commandShowOptions, 27 CommandParse(..), 28 commandParseArgs, 29 getNormalCommandDescriptions, 30 helpCommandUI, 31 32 -- ** Constructing commands 33 ShowOrParseArgs(..), 34 usageDefault, 35 usageAlternatives, 36 mkCommandUI, 37 hiddenCommand, 38 39 -- ** Associating actions with commands 40 Command, 41 commandAddAction, 42 noExtraFlags, 43 44 -- ** Building lists of commands 45 CommandType(..), 46 CommandSpec(..), 47 commandFromSpec, 48 49 -- ** Running commands 50 commandsRun, 51 52-- * Option Fields 53 OptionField(..), Name, 54 55-- ** Constructing Option Fields 56 option, multiOption, 57 58-- ** Liftings & Projections 59 liftOption, 60 61-- * Option Descriptions 62 OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, 63 64-- ** OptDescr 'smart' constructors 65 MkOptDescr, 66 reqArg, reqArg', optArg, optArg', noArg, 67 boolOpt, boolOpt', choiceOpt, choiceOptFromEnum 68 69 ) where 70 71import Prelude () 72import Distribution.Compat.Prelude hiding (get) 73 74import qualified Distribution.GetOpt as GetOpt 75import Distribution.ReadE 76import Distribution.Simple.Utils 77 78 79data CommandUI flags = CommandUI { 80 -- | The name of the command as it would be entered on the command line. 81 -- For example @\"build\"@. 82 commandName :: String, 83 -- | A short, one line description of the command to use in help texts. 84 commandSynopsis :: String, 85 -- | A function that maps a program name to a usage summary for this 86 -- command. 87 commandUsage :: String -> String, 88 -- | Additional explanation of the command to use in help texts. 89 commandDescription :: Maybe (String -> String), 90 -- | Post-Usage notes and examples in help texts 91 commandNotes :: Maybe (String -> String), 92 -- | Initial \/ empty flags 93 commandDefaultFlags :: flags, 94 -- | All the Option fields for this command 95 commandOptions :: ShowOrParseArgs -> [OptionField flags] 96 } 97 98data ShowOrParseArgs = ShowArgs | ParseArgs 99type Name = String 100type Description = String 101 102-- | We usually have a data type for storing configuration values, where 103-- every field stores a configuration option, and the user sets 104-- the value either via command line flags or a configuration file. 105-- An individual OptionField models such a field, and we usually 106-- build a list of options associated to a configuration data type. 107data OptionField a = OptionField { 108 optionName :: Name, 109 optionDescr :: [OptDescr a] } 110 111-- | An OptionField takes one or more OptDescrs, describing the command line 112-- interface for the field. 113data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder 114 (ReadE (a->a)) (a -> [String]) 115 116 | OptArg Description OptFlags ArgPlaceHolder 117 (ReadE (a->a)) (a->a) (a -> [Maybe String]) 118 119 | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] 120 121 | BoolOpt Description OptFlags{-True-} OptFlags{-False-} 122 (Bool -> a -> a) (a-> Maybe Bool) 123 124-- | Short command line option strings 125type SFlags = [Char] 126-- | Long command line option strings 127type LFlags = [String] 128type OptFlags = (SFlags,LFlags) 129type ArgPlaceHolder = String 130 131 132-- | Create an option taking a single OptDescr. 133-- No explicit Name is given for the Option, the name is the first LFlag given. 134option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a 135 -> OptionField a 136option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] 137option _ _ _ _ _ _ = error $ "Distribution.command.option: " 138 ++ "An OptionField must have at least one LFlag" 139 140-- | Create an option taking several OptDescrs. 141-- You will have to give the flags and description individually to the 142-- OptDescr constructor. 143multiOption :: Name -> get -> set 144 -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially 145 -- applied to flags and description. 146 -> OptionField a 147multiOption n get set args = OptionField n [arg get set | arg <- args] 148 149type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set 150 -> OptDescr a 151 152-- | Create a string-valued command line interface. 153reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) 154 -> MkOptDescr (a -> b) (b -> a -> a) a 155reqArg ad mkflag showflag sf lf d get set = 156 ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) 157 (showflag . get) 158 159-- | Create a string-valued command line interface with a default value. 160optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) 161 -> MkOptDescr (a -> b) (b -> a -> a) a 162optArg ad mkflag def showflag sf lf d get set = 163 OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) 164 (\b -> set (get b `mappend` def) b) 165 (showflag . get) 166 167-- | (String -> a) variant of "reqArg" 168reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) 169 -> MkOptDescr (a -> b) (b -> a -> a) a 170reqArg' ad mkflag showflag = 171 reqArg ad (succeedReadE mkflag) showflag 172 173-- | (String -> a) variant of "optArg" 174optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) 175 -> (b -> [Maybe String]) 176 -> MkOptDescr (a -> b) (b -> a -> a) a 177optArg' ad mkflag showflag = 178 optArg ad (succeedReadE (mkflag . Just)) def showflag 179 where def = mkflag Nothing 180 181noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a 182noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d 183 184boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags 185 -> MkOptDescr (a -> b) (b -> a -> a) a 186boolOpt g s sfT sfF _sf _lf@(n:_) d get set = 187 BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) 188boolOpt _ _ _ _ _ _ _ _ _ = error 189 "Distribution.Simple.Setup.boolOpt: unreachable" 190 191boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags 192 -> MkOptDescr (a -> b) (b -> a -> a) a 193boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) 194 195-- | create a Choice option 196choiceOpt :: Eq b => [(b,OptFlags,Description)] 197 -> MkOptDescr (a -> b) (b -> a -> a) a 198choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts 199 where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] 200 201-- | create a Choice option out of an enumeration type. 202-- As long flags, the Show output is used. As short flags, the first character 203-- which does not conflict with a previous one is used. 204choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => 205 MkOptDescr (a -> b) (b -> a -> a) a 206choiceOptFromEnum _sf _lf d get = 207 choiceOpt [ (x, (sf, [map toLower $ show x]), d') 208 | (x, sf) <- sflags' 209 , let d' = d ++ show x] 210 _sf _lf d get 211 where sflags' = foldl f [] [firstOne..] 212 f prev x = let prevflags = concatMap snd prev in 213 prev ++ take 1 [(x, [toLower sf]) 214 | sf <- show x, isAlpha sf 215 , toLower sf `notElem` prevflags] 216 firstOne = minBound `asTypeOf` get undefined 217 218commandGetOpts :: ShowOrParseArgs -> CommandUI flags 219 -> [GetOpt.OptDescr (flags -> flags)] 220commandGetOpts showOrParse command = 221 concatMap viewAsGetOpt (commandOptions command showOrParse) 222 223viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] 224viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa 225 where 226 optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = 227 [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] 228 where set' = readEOrFail set 229 optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = 230 [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] 231 where set' Nothing = def 232 set' (Just txt) = readEOrFail set txt 233 optDescrToGetOpt (ChoiceOpt alts) = 234 [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] 235 optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = 236 [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] 237 optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = 238 [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] 239 optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = 240 [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) 241 , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] 242 243getCurrentChoice :: OptDescr a -> a -> [String] 244getCurrentChoice (ChoiceOpt alts) a = 245 [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] 246 247getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" 248 249 250liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b 251liftOption get' set' opt = 252 opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} 253 254 255liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b 256liftOptDescr get' set' (ChoiceOpt opts) = 257 ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) 258 | (d, ff, set, get) <- opts] 259 260liftOptDescr get' set' (OptArg d ff ad set def get) = 261 OptArg d ff ad (liftSet get' set' `fmap` set) 262 (liftSet get' set' def) (get . get') 263 264liftOptDescr get' set' (ReqArg d ff ad set get) = 265 ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') 266 267liftOptDescr get' set' (BoolOpt d ffT ffF set get) = 268 BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') 269 270liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b 271liftSet get' set' set x = set' (set $ get' x) x 272 273-- | Show flags in the standard long option command line format 274commandShowOptions :: CommandUI flags -> flags -> [String] 275commandShowOptions command v = concat 276 [ showOptDescr v od | o <- commandOptions command ParseArgs 277 , od <- optionDescr o] 278 where 279 maybePrefix [] = [] 280 maybePrefix (lOpt:_) = ["--" ++ lOpt] 281 282 showOptDescr :: a -> OptDescr a -> [String] 283 showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) 284 = case enabled x of 285 Nothing -> [] 286 Just True -> maybePrefix lfTs 287 Just False -> maybePrefix lfFs 288 showOptDescr x c@ChoiceOpt{} 289 = ["--" ++ val | val <- getCurrentChoice c x] 290 showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) 291 = [ "--"++lf++"="++flag 292 | flag <- showflag x ] 293 showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) 294 = [ case flag of 295 Just s -> "--"++lf++"="++s 296 Nothing -> "--"++lf 297 | flag <- showflag x ] 298 showOptDescr _ _ 299 = error "Distribution.Simple.Command.showOptDescr: unreachable" 300 301 302commandListOptions :: CommandUI flags -> [String] 303commandListOptions command = 304 concatMap listOption $ 305 addCommonFlags ShowArgs $ -- This is a slight hack, we don't want 306 -- "--list-options" showing up in the 307 -- list options output, so use ShowArgs 308 commandGetOpts ShowArgs command 309 where 310 listOption (GetOpt.Option shortNames longNames _ _) = 311 [ "-" ++ [name] | name <- shortNames ] 312 ++ [ "--" ++ name | name <- longNames ] 313 314-- | The help text for this command with descriptions of all the options. 315commandHelp :: CommandUI flags -> String -> String 316commandHelp command pname = 317 commandSynopsis command 318 ++ "\n\n" 319 ++ commandUsage command pname 320 ++ ( case commandDescription command of 321 Nothing -> "" 322 Just desc -> '\n': desc pname) 323 ++ "\n" 324 ++ ( if cname == "" 325 then "Global flags:" 326 else "Flags for " ++ cname ++ ":" ) 327 ++ ( GetOpt.usageInfo "" 328 . addCommonFlags ShowArgs 329 $ commandGetOpts ShowArgs command ) 330 ++ ( case commandNotes command of 331 Nothing -> "" 332 Just notes -> '\n': notes pname) 333 where cname = commandName command 334 335-- | Default "usage" documentation text for commands. 336usageDefault :: String -> String -> String 337usageDefault name pname = 338 "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" 339 ++ "Flags for " ++ name ++ ":" 340 341-- | Create "usage" documentation from a list of parameter 342-- configurations. 343usageAlternatives :: String -> [String] -> String -> String 344usageAlternatives name strs pname = unlines 345 [ start ++ pname ++ " " ++ name ++ " " ++ s 346 | let starts = "Usage: " : repeat " or: " 347 , (start, s) <- zip starts strs 348 ] 349 350-- | Make a Command from standard 'GetOpt' options. 351mkCommandUI :: String -- ^ name 352 -> String -- ^ synopsis 353 -> [String] -- ^ usage alternatives 354 -> flags -- ^ initial\/empty flags 355 -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options 356 -> CommandUI flags 357mkCommandUI name synopsis usages flags options = CommandUI 358 { commandName = name 359 , commandSynopsis = synopsis 360 , commandDescription = Nothing 361 , commandNotes = Nothing 362 , commandUsage = usageAlternatives name usages 363 , commandDefaultFlags = flags 364 , commandOptions = options 365 } 366 367-- | Common flags that apply to every command 368data CommonFlag = HelpFlag | ListOptionsFlag 369 370commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] 371commonFlags showOrParseArgs = case showOrParseArgs of 372 ShowArgs -> [help] 373 ParseArgs -> [help, list] 374 where 375 help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) 376 "Show this help text" 377 helpShortFlags = case showOrParseArgs of 378 ShowArgs -> ['h'] 379 ParseArgs -> ['h', '?'] 380 list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) 381 "Print a list of command line flags" 382 383addCommonFlags :: ShowOrParseArgs 384 -> [GetOpt.OptDescr a] 385 -> [GetOpt.OptDescr (Either CommonFlag a)] 386addCommonFlags showOrParseArgs options = 387 map (fmapOptDesc Left) (commonFlags showOrParseArgs) 388 ++ map (fmapOptDesc Right) options 389 where fmapOptDesc f (GetOpt.Option s l d m) = 390 GetOpt.Option s l (fmapArgDesc f d) m 391 fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) 392 fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d 393 fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d 394 395-- | Parse a bunch of command line arguments 396-- 397commandParseArgs :: CommandUI flags 398 -> Bool -- ^ Is the command a global or subcommand? 399 -> [String] 400 -> CommandParse (flags -> flags, [String]) 401commandParseArgs command global args = 402 let options = addCommonFlags ParseArgs 403 $ commandGetOpts ParseArgs command 404 order | global = GetOpt.RequireOrder 405 | otherwise = GetOpt.Permute 406 in case GetOpt.getOpt' order options args of 407 (flags, _, _, _) 408 | any listFlag flags -> CommandList (commandListOptions command) 409 | any helpFlag flags -> CommandHelp (commandHelp command) 410 where listFlag (Left ListOptionsFlag) = True; listFlag _ = False 411 helpFlag (Left HelpFlag) = True; helpFlag _ = False 412 (flags, opts, opts', []) 413 | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') 414 | otherwise -> CommandErrors (unrecognised opts') 415 (_, _, _, errs) -> CommandErrors errs 416 417 where -- Note: It is crucial to use reverse function composition here or to 418 -- reverse the flags here as we want to process the flags left to right 419 -- but data flow in function composition is right to left. 420 accum flags = foldr (flip (.)) id [ f | Right f <- flags ] 421 unrecognised opts = [ "unrecognized " 422 ++ "'" ++ (commandName command) ++ "'" 423 ++ " option `" ++ opt ++ "'\n" 424 | opt <- opts ] 425 -- For unrecognised global flags we put them in the position just after 426 -- the command, if there is one. This gives us a chance to parse them 427 -- as sub-command rather than global flags. 428 mix [] ys = ys 429 mix (x:xs) ys = x:ys++xs 430 431data CommandParse flags = CommandHelp (String -> String) 432 | CommandList [String] 433 | CommandErrors [String] 434 | CommandReadyToGo flags 435instance Functor CommandParse where 436 fmap _ (CommandHelp help) = CommandHelp help 437 fmap _ (CommandList opts) = CommandList opts 438 fmap _ (CommandErrors errs) = CommandErrors errs 439 fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) 440 441 442data CommandType = NormalCommand | HiddenCommand 443data Command action = 444 Command String String ([String] -> CommandParse action) CommandType 445 446-- | Mark command as hidden. Hidden commands don't show up in the 'progname 447-- help' or 'progname --help' output. 448hiddenCommand :: Command action -> Command action 449hiddenCommand (Command name synopsys f _cmdType) = 450 Command name synopsys f HiddenCommand 451 452commandAddAction :: CommandUI flags 453 -> (flags -> [String] -> action) 454 -> Command action 455commandAddAction command action = 456 Command (commandName command) 457 (commandSynopsis command) 458 (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) 459 NormalCommand 460 461 where applyDefaultArgs mkflags args = 462 let flags = mkflags (commandDefaultFlags command) 463 in action flags args 464 465commandsRun :: CommandUI a 466 -> [Command action] 467 -> [String] 468 -> CommandParse (a, CommandParse action) 469commandsRun globalCommand commands args = 470 case commandParseArgs globalCommand True args of 471 CommandHelp help -> CommandHelp help 472 CommandList opts -> CommandList (opts ++ commandNames) 473 CommandErrors errs -> CommandErrors errs 474 CommandReadyToGo (mkflags, args') -> case args' of 475 ("help":cmdArgs) -> handleHelpCommand cmdArgs 476 (name:cmdArgs) -> case lookupCommand name of 477 [Command _ _ action _] 478 -> CommandReadyToGo (flags, action cmdArgs) 479 _ -> CommandReadyToGo (flags, badCommand name) 480 [] -> CommandReadyToGo (flags, noCommand) 481 where flags = mkflags (commandDefaultFlags globalCommand) 482 483 where 484 lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' 485 , cname' == cname ] 486 noCommand = CommandErrors ["no command given (try --help)\n"] 487 badCommand cname = CommandErrors ["unrecognised command: " ++ cname 488 ++ " (try --help)\n"] 489 commands' = commands ++ [commandAddAction helpCommandUI undefined] 490 commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] 491 492 -- A bit of a hack: support "prog help" as a synonym of "prog --help" 493 -- furthermore, support "prog help command" as "prog command --help" 494 handleHelpCommand cmdArgs = 495 case commandParseArgs helpCommandUI True cmdArgs of 496 CommandHelp help -> CommandHelp help 497 CommandList list -> CommandList (list ++ commandNames) 498 CommandErrors _ -> CommandHelp globalHelp 499 CommandReadyToGo (_,[]) -> CommandHelp globalHelp 500 CommandReadyToGo (_,(name:cmdArgs')) -> 501 case lookupCommand name of 502 [Command _ _ action _] -> 503 case action ("--help":cmdArgs') of 504 CommandHelp help -> CommandHelp help 505 CommandList _ -> CommandList [] 506 _ -> CommandHelp globalHelp 507 _ -> badCommand name 508 509 where globalHelp = commandHelp globalCommand 510 511-- | Utility function, many commands do not accept additional flags. This 512-- action fails with a helpful error message if the user supplies any extra. 513-- 514noExtraFlags :: [String] -> IO () 515noExtraFlags [] = return () 516noExtraFlags extraFlags = 517 dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags 518--TODO: eliminate this function and turn it into a variant on commandAddAction 519-- instead like commandAddActionNoArgs that doesn't supply the [String] 520 521-- | Helper function for creating globalCommand description 522getNormalCommandDescriptions :: [Command action] -> [(String, String)] 523getNormalCommandDescriptions cmds = 524 [ (name, description) 525 | Command name description _ NormalCommand <- cmds ] 526 527helpCommandUI :: CommandUI () 528helpCommandUI = 529 (mkCommandUI 530 "help" 531 "Help about commands." 532 ["[FLAGS]", "COMMAND [FLAGS]"] 533 () 534 (const [])) 535 { 536 commandNotes = Just $ \pname -> 537 "Examples:\n" 538 ++ " " ++ pname ++ " help help\n" 539 ++ " Oh, appararently you already know this.\n" 540 } 541 542-- | wraps a @CommandUI@ together with a function that turns it into a @Command@. 543-- By hiding the type of flags for the UI allows construction of a list of all UIs at the 544-- top level of the program. That list can then be used for generation of manual page 545-- as well as for executing the selected command. 546data CommandSpec action 547 = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType 548 549commandFromSpec :: CommandSpec a -> Command a 550commandFromSpec (CommandSpec ui action _) = action ui 551