Command.hs 24.6 KB
Newer Older
1
{-# LANGUAGE ExistentialQuantification #-}
2
3
4
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

5
6
7
8
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Command
-- Copyright   :  Duncan Coutts 2007
9
-- License     :  BSD3
10
--
Duncan Coutts's avatar
Duncan Coutts committed
11
-- Maintainer  :  cabal-devel@haskell.org
12
-- Portability :  non-portable (ExistentialQuantification)
13
--
Duncan Coutts's avatar
Duncan Coutts committed
14
15
16
17
18
19
20
-- 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@.
21
22

module Distribution.Simple.Command (
23
24

  -- * Command interface
25
  CommandUI(..),
26
  commandShowOptions,
Duncan Coutts's avatar
Duncan Coutts committed
27
28
  CommandParse(..),
  commandParseArgs,
29
30
  getNormalCommandDescriptions,
  helpCommandUI,
31

32
  -- ** Constructing commands
33
  ShowOrParseArgs(..),
34
35
36
  usageDefault,
  usageAlternatives,
  mkCommandUI,
37
  hiddenCommand,
38
39

  -- ** Associating actions with commands
40
41
  Command,
  commandAddAction,
42
  noExtraFlags,
43

44
45
46
47
48
  -- ** Building lists of commands
  CommandType(..),
  CommandSpec(..),
  commandFromSpec,

49
  -- ** Running commands
50
  commandsRun,
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65

-- * 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,
66
  reqArg, reqArg', optArg, optArg', noArg,
67
68
  boolOpt, boolOpt', choiceOpt, choiceOptFromEnum

69
70
  ) where

71
72
73
import Prelude ()
import Distribution.Compat.Prelude hiding (get)

74
75
76
77
78
79
import qualified Distribution.GetOpt as GetOpt
import Distribution.Text
import Distribution.ParseUtils
import Distribution.ReadE
import Distribution.Simple.Utils

80
81
import Text.PrettyPrint ( punctuate, cat, comma, text )
import Text.PrettyPrint as PP ( empty )
82
83
84
85
86
87
88

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,
89
90
    -- | A function that maps a program name to a usage summary for this
    -- command.
91
92
93
    commandUsage    :: String -> String,
    -- | Additional explanation of the command to use in help texts.
    commandDescription :: Maybe (String -> String),
94
95
    -- | Post-Usage notes and examples in help texts
    commandNotes :: Maybe (String -> String),
96
    -- | Initial \/ empty flags
97
    commandDefaultFlags :: flags,
98
99
    -- | All the Option fields for this command
    commandOptions     :: ShowOrParseArgs -> [OptionField flags]
100
101
102
  }

data ShowOrParseArgs = ShowArgs | ParseArgs
103
104
105
type Name        = String
type Description = String

Ian D. Bollinger's avatar
Ian D. Bollinger committed
106
-- | We usually have a data type for storing configuration values, where
107
108
109
--   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
Ian D. Bollinger's avatar
Ian D. Bollinger committed
110
--   build a list of options associated to a configuration data type.
111
112
113
114
data OptionField a = OptionField {
  optionName        :: Name,
  optionDescr       :: [OptDescr a] }

refold's avatar
refold committed
115
116
117
118
119
120
121
122
-- | 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])

123
                 | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]
refold's avatar
refold committed
124
125
126

                 | BoolOpt Description OptFlags{-True-} OptFlags{-False-}
                   (Bool -> a -> a) (a-> Maybe Bool)
127
128
129
130
131
132
133
134
135
136
137

-- | 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.
refold's avatar
refold committed
138
139
option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a
          -> OptionField a
mnislaih's avatar
mnislaih committed
140
option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set]
refold's avatar
refold committed
141
142
option _ _ _ _ _ _ = error $ "Distribution.command.option: "
                     ++ "An OptionField must have at least one LFlag"
143
144

-- | Create an option taking several OptDescrs.
refold's avatar
refold committed
145
146
--   You will have to give the flags and description individually to the
--   OptDescr constructor.
147
multiOption :: Name -> get -> set
refold's avatar
refold committed
148
149
            -> [get -> set -> OptDescr a]  -- ^MkOptDescr constructors partially
                                           -- applied to flags and description.
150
151
152
            -> OptionField a
multiOption n get set args = OptionField n [arg get set | arg <- args]

refold's avatar
refold committed
153
154
type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set
                            -> OptDescr a
155
156
157
158
159

-- | 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 =
refold's avatar
refold committed
160
161
  ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)
  (showflag . get)
162
163
164
165
166
167
168
169

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

171
172
173
174
175
-- | (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
176

177
-- | (String -> a) variant of "optArg"
178
optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)
refold's avatar
refold committed
179
180
           -> (b -> [Maybe String])
           -> MkOptDescr (a -> b) (b -> a -> a) a
181
182
183
optArg' ad mkflag showflag =
    optArg ad (succeedReadE (mkflag . Just)) def showflag
      where def = mkflag Nothing
184

185
noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a
186
noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d
187

refold's avatar
refold committed
188
189
boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags
           -> MkOptDescr (a -> b) (b -> a -> a) a
190
boolOpt g s sfT sfF _sf _lf@(n:_) d get set =
191
    BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)
refold's avatar
refold committed
192
193
boolOpt _ _ _ _ _ _ _ _ _ = error
                            "Distribution.Simple.Setup.boolOpt: unreachable"
194

refold's avatar
refold committed
195
196
boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags
            -> MkOptDescr (a -> b) (b -> a -> a) a
197
boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)
198

199
-- | create a Choice option
refold's avatar
refold committed
200
201
choiceOpt :: Eq b => [(b,OptFlags,Description)]
             -> MkOptDescr (a -> b) (b -> a -> a) a
202
203
choiceOpt aa_ff _sf _lf _d get set  = ChoiceOpt alts
    where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]
204

205
206
207
-- | 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.
refold's avatar
refold committed
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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)]
224
commandGetOpts showOrParse command =
225
    concatMap viewAsGetOpt (commandOptions command showOrParse)
226

227
228
viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]
viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
229
230
231
232
233
234
235
236
237
  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) =
238
         [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]
239
240
241
242
243
    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 _) =
244
245
         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))  ("Enable " ++ d)
         , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]
246

refold's avatar
refold committed
247
248
-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >
-- Choice > Opt) and consider only the first one.
249
viewAsFieldDescr :: OptionField a -> FieldDescr a
refold's avatar
refold committed
250
251
viewAsFieldDescr (OptionField _n []) =
  error "Distribution.command.viewAsFieldDescr: unexpected"
252
viewAsFieldDescr (OptionField n dd) = FieldDescr n get set
refold's avatar
refold committed
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    where
      optDescr = head $ sortBy cmp dd

      cmp :: OptDescr a -> OptDescr a -> Ordering
      ReqArg{}    `cmp` ReqArg{}    = EQ
      ReqArg{}    `cmp` _           = GT
      BoolOpt{}   `cmp` ReqArg{}    = LT
      BoolOpt{}   `cmp` BoolOpt{}   = EQ
      BoolOpt{}   `cmp` _           = GT
      ChoiceOpt{} `cmp` ReqArg{}    = LT
      ChoiceOpt{} `cmp` BoolOpt{}   = LT
      ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
      ChoiceOpt{} `cmp` _           = GT
      OptArg{}    `cmp` OptArg{}    = EQ
      OptArg{}    `cmp` _           = LT

--    get :: a -> Doc
      get t = case optDescr of
        ReqArg _ _ _ _ ppr ->
          (cat . punctuate comma . map text . ppr) t

        OptArg _ _ _ _ _ ppr ->
275
          case ppr t of []        -> PP.empty
276
277
                        (Nothing : _) -> text "True"
                        (Just a  : _) -> text a
refold's avatar
refold committed
278
279

        ChoiceOpt alts ->
280
          fromMaybe PP.empty $ listToMaybe
refold's avatar
refold committed
281
282
          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]

283
        BoolOpt _ _ _ _ enabled -> (maybe PP.empty disp . enabled) t
refold's avatar
refold committed
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

--    set :: LineNo -> String -> a -> ParseResult a
      set line val a =
        case optDescr of
          ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE val
                                     -- 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 val of
              Just f -> return (f a)
              _      -> syntaxError line val

          BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runP line n parse val

          OptArg _ _ _  readE _ _ -> ($ a) `liftM` runE line n readE val
                                     -- Optional arguments are parsed just like
                                     -- required arguments here; we don't
                                     -- provide a method to set an OptArg field
                                     -- to the default value.
305
306

getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)
refold's avatar
refold committed
307
308
309
getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe
                                           [ set | (_,(_sf,lf:_), set, _) <- alts
                                                 , lf == val]
310

refold's avatar
refold committed
311
312
getChoiceByLongFlag _ _ =
  error "Distribution.command.getChoiceByLongFlag: expected a choice option"
313
314
315
316
317
318
319
320
321

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
refold's avatar
refold committed
322
323
liftOption get' set' opt =
  opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}
324
325
326
327
328
329
330
331


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) =
refold's avatar
refold committed
332
333
    OptArg d ff ad (liftSet get' set' `fmap` set)
    (liftSet get' set' def) (get . get')
334
335
336
337
338

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) =
339
    BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')
340
341
342

liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b
liftSet get' set' set x = set' (set $ get' x) x
343
344
345

-- | Show flags in the standard long option command line format
commandShowOptions :: CommandUI flags -> flags -> [String]
346
commandShowOptions command v = concat
mnislaih's avatar
Wibbles    
mnislaih committed
347
348
  [ showOptDescr v  od | o <- commandOptions command ParseArgs
                       , od <- optionDescr o]
349
  where
350
351
352
    maybePrefix []       = []
    maybePrefix (lOpt:_) = ["--" ++ lOpt]

mnislaih's avatar
Wibbles    
mnislaih committed
353
    showOptDescr :: a -> OptDescr a -> [String]
354
    showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled)
355
356
      = case enabled x of
          Nothing -> []
357
358
          Just True  -> maybePrefix lfTs
          Just False -> maybePrefix lfFs
mnislaih's avatar
Wibbles    
mnislaih committed
359
    showOptDescr x c@ChoiceOpt{}
360
      = ["--" ++ val | val <- getCurrentChoice c x]
mnislaih's avatar
Wibbles    
mnislaih committed
361
362
    showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)
      = [ "--"++lf++"="++flag
363
        | flag <- showflag x ]
mnislaih's avatar
Wibbles    
mnislaih committed
364
    showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag)
365
      = [ case flag of
mnislaih's avatar
Wibbles    
mnislaih committed
366
367
            Just s  -> "--"++lf++"="++s
            Nothing -> "--"++lf
368
        | flag <- showflag x ]
Duncan Coutts's avatar
Duncan Coutts committed
369
370
    showOptDescr _ _
      = error "Distribution.Simple.Command.showOptDescr: unreachable"
371

372

373
374
commandListOptions :: CommandUI flags -> [String]
commandListOptions command =
375
376
377
378
  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
379
      commandGetOpts ShowArgs command
380
  where
381
    listOption (GetOpt.Option shortNames longNames _ _) =
382
383
384
         [ "-"  ++ [name] | name <- shortNames ]
      ++ [ "--" ++  name  | name <- longNames ]

385
-- | The help text for this command with descriptions of all the options.
386
387
commandHelp :: CommandUI flags -> String -> String
commandHelp command pname =
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
    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
405

406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
-- | 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
  ]

421
-- | Make a Command from standard 'GetOpt' options.
422
423
424
425
mkCommandUI :: String          -- ^ name
            -> String          -- ^ synopsis
            -> [String]        -- ^ usage alternatives
            -> flags           -- ^ initial\/empty flags
426
            -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options
427
            -> CommandUI flags
428
429
430
431
432
433
434
435
mkCommandUI name synopsis usages flags options = CommandUI
  { commandName         = name
  , commandSynopsis     = synopsis
  , commandDescription  = Nothing
  , commandNotes        = Nothing
  , commandUsage        = usageAlternatives name usages
  , commandDefaultFlags = flags
  , commandOptions      = options
436
  }
437
438

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

441
442
443
444
commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]
commonFlags showOrParseArgs = case showOrParseArgs of
  ShowArgs  -> [help]
  ParseArgs -> [help, list]
445
 where
446
    help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag)
447
             "Show this help text"
448
449
450
    helpShortFlags = case showOrParseArgs of
      ShowArgs  -> ['h']
      ParseArgs -> ['h', '?']
451
452
    list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag)
             "Print a list of command line flags"
453

454
455
addCommonFlags :: ShowOrParseArgs
               -> [GetOpt.OptDescr a]
456
               -> [GetOpt.OptDescr (Either CommonFlag a)]
457
458
459
460
461
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
462
463
464
        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
465

Duncan Coutts's avatar
Duncan Coutts committed
466
467
468
469
470
-- | Parse a bunch of command line arguments
--
commandParseArgs :: CommandUI flags
                 -> Bool      -- ^ Is the command a global or subcommand?
                 -> [String]
471
                 -> CommandParse (flags -> flags, [String])
472
commandParseArgs command global args =
473
  let options = addCommonFlags ParseArgs
474
              $ commandGetOpts ParseArgs command
475
      order | global    = GetOpt.RequireOrder
476
            | otherwise = GetOpt.Permute
477
478
479
480
481
482
483
484
485
486
  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
487

488
  where -- Note: It is crucial to use reverse function composition here or to
489
        -- reverse the flags here as we want to process the flags left to right
Ian D. Bollinger's avatar
Ian D. Bollinger committed
490
        -- but data flow in function composition is right to left.
491
        accum flags = foldr (flip (.)) id [ f | Right f <- flags ]
492
493
494
        unrecognised opts = [ "unrecognized "
                              ++ "'" ++ (commandName command) ++ "'"
                              ++ " option `" ++ opt ++ "'\n"
495
496
497
498
499
500
                            | 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
501
502

data CommandParse flags = CommandHelp (String -> String)
503
                        | CommandList [String]
504
505
506
507
                        | CommandErrors [String]
                        | CommandReadyToGo flags
instance Functor CommandParse where
  fmap _ (CommandHelp help)       = CommandHelp help
508
  fmap _ (CommandList opts)       = CommandList opts
509
  fmap _ (CommandErrors errs)     = CommandErrors errs
510
  fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)
511
512


513
514
515
516
517
518
519
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
tibbe's avatar
tibbe committed
520
hiddenCommand (Command name synopsys f _cmdType) =
521
  Command name synopsys f HiddenCommand
522
523
524
525
526
527
528

commandAddAction :: CommandUI flags
                 -> (flags -> [String] -> action)
                 -> Command action
commandAddAction command action =
  Command (commandName command)
          (commandSynopsis command)
529
530
          (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)
          NormalCommand
531
532
533
534
535

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

536
537
538
539
540
commandsRun :: CommandUI a
            -> [Command action]
            -> [String]
            -> CommandParse (a, CommandParse action)
commandsRun globalCommand commands args =
541
  case commandParseArgs globalCommand True args of
542
543
    CommandHelp      help          -> CommandHelp help
    CommandList      opts          -> CommandList (opts ++ commandNames)
544
    CommandErrors    errs          -> CommandErrors errs
545
    CommandReadyToGo (mkflags, args') -> case args' of
546
      ("help":cmdArgs) -> handleHelpCommand cmdArgs
547
548
549
550
551
      (name:cmdArgs)   -> case lookupCommand name of
        [Command _ _ action _]
          -> CommandReadyToGo (flags, action cmdArgs)
        _ -> CommandReadyToGo (flags, badCommand name)
      []               -> CommandReadyToGo (flags, noCommand)
552
     where flags = mkflags (commandDefaultFlags globalCommand)
553

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

563
564
565
566
567
568
569
570
571
572
    -- 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
573
            [Command _ _ action _] ->
574
575
576
577
578
579
              case action ("--help":cmdArgs') of
                CommandHelp help -> CommandHelp help
                CommandList _    -> CommandList []
                _                -> CommandHelp globalHelp
            _                    -> badCommand name

580
     where globalHelp = commandHelp globalCommand
581

582
583
584
585
586
587
588
589
590
-- | 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 =
  die $ "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]
591
592
593
594
595
596
597
598

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

helpCommandUI :: CommandUI ()
599
600
601
602
603
604
605
606
607
608
609
610
611
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"
  }
612
613
614
615
616
617
618
619
620
621

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