Setup.hs 89 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
3
-----------------------------------------------------------------------------
-- |
4
-- Module      :  Distribution.Client.Setup
5
6
7
8
9
10
11
12
13
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
14
module Distribution.Client.Setup
Edsko de Vries's avatar
Edsko de Vries committed
15
16
    ( globalCommand, GlobalFlags(..), defaultGlobalFlags
    , RepoContext(..), withRepoContext
17
    , configureCommand, ConfigFlags(..), filterConfigureFlags
18
19
    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
                        , configureExOptions
20
    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
21
    , replCommand, testCommand, benchmarkCommand
22
    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
23
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
24
    , updateCommand
ijones's avatar
ijones committed
25
    , upgradeCommand
26
    , uninstallCommand
27
    , infoCommand, InfoFlags(..)
28
    , fetchCommand, FetchFlags(..)
29
    , freezeCommand, FreezeFlags(..)
30
    , getCommand, unpackCommand, GetFlags(..)
31
    , checkCommand
32
    , formatCommand
33
    , uploadCommand, UploadFlags(..)
34
    , reportCommand, ReportFlags(..)
refold's avatar
refold committed
35
    , runCommand
36
    , initCommand, IT.InitFlags(..)
37
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
38
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
39
    , actAsSetupCommand, ActAsSetupFlags(..)
refold's avatar
refold committed
40
    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
41
    , execCommand, ExecFlags(..)
42
    , userConfigCommand, UserConfigFlags(..)
Maciek Makowski's avatar
Maciek Makowski committed
43
    , manpageCommand
Duncan Coutts's avatar
Duncan Coutts committed
44
45

    , parsePackageArgs
46
47
48
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
49
    , readRepo
50
51
    ) where

52
import Distribution.Client.Types
Edsko de Vries's avatar
Edsko de Vries committed
53
         ( Username(..), Password(..), RemoteRepo(..) )
54
55
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
56
import Distribution.Client.Dependency.Types
57
         ( AllowNewer(..), PreSolver(..), ConstraintSource(..) )
58
59
import qualified Distribution.Client.Init.Types as IT
         ( InitFlags(..), PackageType(..) )
60
61
import Distribution.Client.Targets
         ( UserConstraint, readUserConstraint )
62
63
import Distribution.Utils.NubList
         ( NubList, toNubList, fromNubList)
64

65

66
import Distribution.Simple.Compiler (PackageDB)
67
68
import Distribution.Simple.Program
         ( defaultProgramConfiguration )
69
70
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
Duncan Coutts's avatar
Duncan Coutts committed
71
import qualified Distribution.Simple.Setup as Cabal
72
import Distribution.Simple.Setup
73
74
         ( ConfigFlags(..), BuildFlags(..), ReplFlags
         , TestFlags(..), BenchmarkFlags(..)
75
         , SDistFlags(..), HaddockFlags(..)
76
         , readPackageDbList, showPackageDbList
Edsko de Vries's avatar
Edsko de Vries committed
77
         , Flag(..), toFlag, flagToMaybe, flagToList
78
         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs )
79
import Distribution.Simple.InstallDirs
80
81
         ( PathTemplate, InstallDirs(sysconfdir)
         , toPathTemplate, fromPathTemplate )
82
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
83
         ( Version(Version), anyVersion, thisVersion )
84
import Distribution.Package
85
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
86
import Distribution.PackageDescription
87
         ( BuildType(..), RepoKind(..) )
88
import Distribution.Text
89
         ( Text(..), display )
90
import Distribution.ReadE
91
         ( ReadE(..), readP_to_E, succeedReadE )
92
import qualified Distribution.Compat.ReadP as Parse
93
         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )
94
95
import Distribution.Verbosity
         ( Verbosity, normal )
96
import Distribution.Simple.Utils
97
         ( wrapText, wrapLine )
98
import Distribution.Client.GlobalFlags
Edsko de Vries's avatar
Edsko de Vries committed
99
100
101
         ( GlobalFlags(..), defaultGlobalFlags
         , RepoContext(..), withRepoContext
         )
102

103
104
import Data.Char
         ( isSpace, isAlphaNum )
105
import Data.List
106
         ( intercalate, deleteFirstsBy )
107
import Data.Maybe
108
         ( listToMaybe, maybeToList, fromMaybe )
109
#if !MIN_VERSION_base(4,8,0)
110
111
import Data.Monoid
         ( Monoid(..) )
112
#endif
113
114
115
116
117
118
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
119

120
121
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
122
    commandName         = "",
123
124
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
125
126
127
128
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
129
    commandDescription  = Just $ \pname ->
130
131
132
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
        -- if new commands are added, we want them to appear even if they
        -- are not included in the custom listing below. Thus, we calculate
        -- the `otherCmds` list and append it under the `other` category.
        -- Alternatively, a new testcase could be added that ensures that
        -- the set of commands listed here is equal to the set of commands
        -- that are actually available.
        otherCmds = deleteFirstsBy (==) (map fst cmdDescs)
          [ "help"
          , "update"
          , "install"
          , "fetch"
          , "list"
          , "info"
          , "user-config"
          , "get"
          , "init"
          , "configure"
          , "build"
          , "clean"
          , "run"
          , "repl"
          , "test"
          , "bench"
          , "check"
          , "sdist"
          , "upload"
          , "report"
          , "freeze"
          , "haddock"
          , "hscolour"
          , "copy"
          , "register"
          , "sandbox"
          , "exec"
          ]
168
169
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
170
171
172
173
174
175
176
177
178
        startGroup n = " ["++n++"]"
        par          = ""
        addCmd n     = case lookup n cmdDescs of
                         Nothing -> ""
                         Just d -> "  " ++ align n ++ "    " ++ d
        addCmdCustom n d = case lookup n cmdDescs of -- make sure that the
                                                  -- command still exists.
                         Nothing -> ""
                         Just _ -> "  " ++ align n ++ "    " ++ d
179
180
      in
         "Commands:\n"
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
      ++ unlines (
        [ startGroup "global"
        , addCmd "update"
        , addCmd "install"
        , par
        , addCmd "help"
        , addCmd "info"
        , addCmd "list"
        , addCmd "fetch"
        , addCmd "user-config"
        , par
        , startGroup "package"
        , addCmd "get"
        , addCmd "init"
        , par
        , addCmd "configure"
        , addCmd "build"
        , addCmd "clean"
        , par
        , addCmd "run"
        , addCmd "repl"
        , addCmd "test"
        , addCmd "bench"
        , par
        , addCmd "check"
        , addCmd "sdist"
        , addCmd "upload"
        , addCmd "report"
        , par
        , addCmd "freeze"
        , addCmd "haddock"
        , addCmd "hscolour"
        , addCmd "copy"
        , addCmd "register"
        , par
        , startGroup "sandbox"
217
        , addCmd "sandbox"
218
219
220
221
222
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
223
224
      ++ "\n"
      ++ "For more information about a command use:\n"
225
226
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
227
      ++ "\n"
228
      ++ "To install Cabal packages from hackage use:\n"
229
230
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
231
232
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
233
    commandNotes = Nothing,
234
    commandDefaultFlags = mempty,
235
236
237
238
239
240
241
242
243
244
245
    commandOptions = args
  }
  where
    args :: ShowOrParseArgs -> [OptionField GlobalFlags]
    args ShowArgs  = argsShown
    args ParseArgs = argsShown ++ argsNotShown

    -- arguments we want to show in the help
    argsShown :: [OptionField GlobalFlags]
    argsShown = [
       option ['V'] ["version"]
246
247
248
249
250
251
252
253
254
255
256
257
258
259
         "Print version information"
         globalVersion (\v flags -> flags { globalVersion = v })
         trueArg

      ,option [] ["numeric-version"]
         "Print just the version number"
         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })
         trueArg

      ,option [] ["config-file"]
         "Set an alternate location for the config file"
         globalConfigFile (\v flags -> flags { globalConfigFile = v })
         (reqArgFlag "FILE")

260
      ,option [] ["sandbox-config-file"]
261
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
262
263
264
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
265
266
      ,option [] ["default-user-config"]
         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
267
268
269
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

270
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
271
         "requiring the presence of a sandbox for sandbox-aware commands"
272
273
274
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

275
276
277
278
279
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

280
      ,option [] ["ignore-expiry"]
Edsko de Vries's avatar
Edsko de Vries committed
281
         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
282
283
284
         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
         trueArg

285
      ,option [] ["http-transport"]
286
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
287
288
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")
289
      ]
290

291
292
293
294
    -- arguments we don't want shown in the help
    argsNotShown :: [OptionField GlobalFlags]
    argsNotShown = [
       option [] ["remote-repo"]
295
296
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
297
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
298
299
300
301
302
303
304
305
306

      ,option [] ["remote-repo-cache"]
         "The location where downloads from all remote repos are cached"
         globalCacheDir (\v flags -> flags { globalCacheDir = v })
         (reqArgFlag "DIR")

      ,option [] ["local-repo"]
         "The location of a local repository"
         globalLocalRepos (\v flags -> flags { globalLocalRepos = v })
307
         (reqArg' "DIR" (\x -> toNubList [x]) fromNubList)
308

309
310
311
312
313
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

314
315
316
317
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
318
319
320
321
322
      ]

-- ------------------------------------------------------------
-- * Config flags
-- ------------------------------------------------------------
Duncan Coutts's avatar
Duncan Coutts committed
323

324
configureCommand :: CommandUI ConfigFlags
325
326
configureCommand = c
  { commandDefaultFlags = mempty
327
328
329
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
330
331
332
333
334
335
       ++ "Examples:\n"
       ++ "  " ++ pname ++ " configure\n"
       ++ "    Configure with defaults;\n"
       ++ "  " ++ pname ++ " configure --enable-tests -fcustomflag\n"
       ++ "    Configure building package including tests,\n"
       ++ "    with some package-specific flag.\n"
Duncan Coutts's avatar
Duncan Coutts committed
336
  }
337
338
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
339

340
341
342
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

343
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
344
filterConfigureFlags flags cabalLibVersion
345
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
346
  -- ^ NB: we expect the latest version to be the most common case.
347
348
349
  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10
  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0
  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0
350
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
351
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
352
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
353
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
354
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
355
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
356
  | otherwise = flags_latest
357
  where
358
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
359
360
    flags_latest = flags        { configConstraints = [] }

361
362
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
363
364
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
365

366
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
367
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
368

369
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
370
371
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
372
      flags_1_21_0 { configRelocatable = NoFlag
373
374
375
376
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
377
378
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
379
                   }
380
381
382
383
    -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and
    -- '--enable-library-stripping'.
    flags_1_19_1 = flags_1_20_0 { configExactConfiguration = NoFlag
                                , configStripLibs = NoFlag }
384
385
386
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
387
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
388
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
389
390
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
391
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
392
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
393
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
394
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
395
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
396
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
397

398
399
400
401
402
403
404
405
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
406
    configExConstraints:: [(UserConstraint, ConstraintSource)],
407
    configPreferences  :: [Dependency],
408
409
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
410
411
412
  }

defaultConfigExFlags :: ConfigExFlags
413
414
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
415
416
417
418
419

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
420
         liftOptions fst setFst
421
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
422
                  . optionName) $ configureOptions  showOrParseArgs)
423
424
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
425
426
427
428
429
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

430
431
432
433
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
434
435
436
437
438
439
440
  [ option [] ["cabal-lib-version"]
      ("Select which version of the Cabal lib to use to build packages "
      ++ "(useful for testing).")
      configCabalVersion (\v flags -> flags { configCabalVersion = v })
      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
                                    (fmap toFlag parse))
                        (map display . flagToList))
441
442
443
444
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
445
446
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
447
448
449
450

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
451
452
453
454
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
455
456

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
457
458

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
459
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
460
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
461
    (optArg allowNewerArgument
462
463
464
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

465
  ]
cheecheeo's avatar
cheecheeo committed
466
  where allowNewerArgument = "DEPS"
467
468
469
470

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
471
    configExConstraints= mempty,
472
    configPreferences  = mempty,
473
474
    configSolver       = mempty,
    configAllowNewer   = mempty
475
476
477
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
478
    configExConstraints= combine configExConstraints,
479
    configPreferences  = combine configPreferences,
480
481
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
482
483
484
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
485
486
487
488
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

489
490
491
492
493
494
495
496
497
498
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
499
  option [] ["only"]
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
  "Don't reinstall add-source dependencies (sandbox-only)"
  buildOnly (\v flags -> flags { buildOnly = v })
  (noArg (Flag SkipAddSourceDepsCheck))

  : []

buildCommand :: CommandUI (BuildFlags, BuildExFlags)
buildCommand = parent {
    commandDefaultFlags = (commandDefaultFlags parent, mempty),
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
                          (commandOptions parent showOrParseArgs)
                          ++
                          liftOptions snd setSnd (buildExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

    parent = Cabal.buildCommand defaultProgramConfiguration

instance Monoid BuildExFlags where
  mempty = BuildExFlags {
    buildOnly    = mempty
  }
  mappend a b = BuildExFlags {
    buildOnly    = combine buildOnly
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
-- * Repl command
-- ------------------------------------------------------------

replCommand :: CommandUI (ReplFlags, BuildExFlags)
replCommand = parent {
    commandDefaultFlags = (commandDefaultFlags parent, mempty),
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
                          (commandOptions parent showOrParseArgs)
                          ++
                          liftOptions snd setSnd (buildExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

    parent = Cabal.replCommand defaultProgramConfiguration

549
550
551
552
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

553
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
554
testCommand = parent {
555
556
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
557
  commandOptions      =
558
    \showOrParseArgs -> liftOptions get1 set1
559
560
                        (commandOptions parent showOrParseArgs)
                        ++
561
562
563
564
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
565
566
  }
  where
567
568
569
    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
570

571
572
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
573
574
575
576
577

-- ------------------------------------------------------------
-- * Bench command
-- ------------------------------------------------------------

578
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
579
benchmarkCommand = parent {
580
581
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
582
  commandOptions      =
583
    \showOrParseArgs -> liftOptions get1 set1
584
585
                        (commandOptions parent showOrParseArgs)
                        ++
586
587
588
589
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
590
  }
591
  where
592
593
594
    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
595

596
597
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
598

599
-- ------------------------------------------------------------
600
-- * Fetch command
601
-- ------------------------------------------------------------
602

603
604
605
606
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
607
      fetchSolver           :: Flag PreSolver,
608
609
610
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
611
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
612
      fetchStrongFlags      :: Flag Bool,
613
614
615
616
617
618
619
620
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
621
622
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
623
    fetchReorderGoals     = Flag False,
624
    fetchIndependentGoals = Flag False,
625
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
626
    fetchStrongFlags      = Flag False,
627
628
629
630
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
631
632
fetchCommand = CommandUI {
    commandName         = "fetch",
633
    commandSynopsis     = "Downloads packages for later installation.",
634
635
636
637
638
    commandUsage        = usageAlternatives "fetch" [ "[FLAGS] PACKAGES"
                                                    ],
    commandDescription  = Just $ \_ ->
          "Note that it currently is not possible to fetch the dependencies for a\n"
       ++ "package in the current directory.\n",
639
    commandNotes        = Nothing,
640
    commandDefaultFlags = defaultFetchFlags,
641
    commandOptions      = \ showOrParseArgs -> [
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
         optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })

--     , option "o" ["output"]
--         "Put the package(s) somewhere specific rather than the usual cache."
--         fetchOutput (\v flags -> flags { fetchOutput = v })
--         (reqArgFlag "PATH")

       , option [] ["dependencies", "deps"]
           "Resolve and fetch dependencies (default)"
           fetchDeps (\v flags -> flags { fetchDeps = v })
           trueArg

       , option [] ["no-dependencies", "no-deps"]
           "Ignore dependencies"
           fetchDeps (\v flags -> flags { fetchDeps = v })
           falseArg

       , option [] ["dry-run"]
           "Do not install anything, only print what would be installed."
           fetchDryRun (\v flags -> flags { fetchDryRun = v })
           trueArg
663
664
665
666

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
667
668
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
669
670
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
671
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
672
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
673

Duncan Coutts's avatar
Duncan Coutts committed
674
675
  }

676
677
678
679
680
681
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
682
683
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
684
685
686
687
688
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
689
      freezeStrongFlags      :: Flag Bool,
690
691
692
693
694
695
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
696
697
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
698
699
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
700
    freezeReorderGoals     = Flag False,
701
702
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
703
    freezeStrongFlags      = Flag False,
704
705
706
707
708
709
710
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
711
712
713
714
715
716
717
718
    commandDescription  = Just $ \_ -> wrapText $
         "Calculates a valid set of dependencies and their exact versions. "
      ++ "If successful, saves the result to the file `cabal.config`.\n"
      ++ "\n"
      ++ "The package versions specified in `cabal.config` will be used for "
      ++ "any future installs.\n"
      ++ "\n"
      ++ "An existing `cabal.config` is ignored and overwritten.\n",
719
    commandNotes        = Nothing,
720
    commandUsage        = usageFlags "freeze",
721
722
723
724
725
726
727
728
729
    commandDefaultFlags = defaultFreezeFlags,
    commandOptions      = \ showOrParseArgs -> [
         optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })

       , option [] ["dry-run"]
           "Do not freeze anything, only print what would be frozen"
           freezeDryRun (\v flags -> flags { freezeDryRun = v })
           trueArg

730
731
732
733
734
735
736
737
738
739
       , option [] ["tests"]
           "freezing of the dependencies of any tests suites in the package description file."
           freezeTests (\v flags -> flags { freezeTests = v })
           (boolOpt [] [])

       , option [] ["benchmarks"]
           "freezing of the dependencies of any benchmarks suites in the package description file."
           freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v })
           (boolOpt [] [])

740
741
742
743
744
745
746
747
       ] ++

       optionSolver      freezeSolver           (\v flags -> flags { freezeSolver           = v }) :
       optionSolverFlags showOrParseArgs
                         freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })
                         freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })
                         freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
                         freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
748
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
749
750
751

  }

752
753
754
755
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

756
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
757
758
updateCommand = CommandUI {
    commandName         = "update",
759
    commandSynopsis     = "Updates list of known packages.",
760
761
762
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
763
764
765
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
766
    commandUsage        = usageFlags "update",
767
    commandDefaultFlags = toFlag normal,
768
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
769
770
  }

771
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
772
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
773
    commandName         = "upgrade",
774
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
775
    commandDescription  = Nothing,
refold's avatar
refold committed
776
    commandUsage        = usageFlagsOrPackages "upgrade",
777
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
778
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
779
780
  }

Duncan Coutts's avatar
Duncan Coutts committed
781
782
783
784
785
786
787
788
789
790
791
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

792
793
794
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
795
    commandSynopsis     = "Check the package for common mistakes.",
796
797
798
799
800
801
    commandDescription  = Just $ \_ -> wrapText $
         "Expects a .cabal package file in the current directory.\n"
      ++ "\n"
      ++ "The checks correspond to the requirements to packages on Hackage. "
      ++ "If no errors and warnings are reported, Hackage will accept this "
      ++ "package.\n",
802
    commandNotes        = Nothing,
803
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
804
    commandDefaultFlags = toFlag normal,
805
    commandOptions      = \_ -> []
806
807
  }

808
809
810
811
812
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
813
    commandNotes        = Nothing,
814
    commandUsage        = usageAlternatives "format" ["[FILE]"],
815
816
817
818
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

819
820
821
822
823
824
825
826
827
828
829
uninstallCommand  :: CommandUI (Flag Verbosity)
uninstallCommand = CommandUI {
    commandName         = "uninstall",
    commandSynopsis     = "Warn about 'uninstall' not being implemented.",
    commandDescription  = Nothing,
    commandNotes        = Nothing,
    commandUsage        = usageAlternatives "uninstall" ["PACKAGES"],
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

Maciek Makowski's avatar
Maciek Makowski committed
830
831
832
833
834
835
836
837
838
839
840
841
manpageCommand :: CommandUI (Flag Verbosity)
manpageCommand = CommandUI {
    commandName         = "manpage",
    commandSynopsis     = "Outputs manpage source.",
    commandDescription  = Just $ \_ ->
      "Output manpage source to STDOUT.\n",
    commandNotes        = Nothing,
    commandUsage        = usageFlags "manpage",
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> [optionVerbosity id const]
  }

842
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
843
844
runCommand = CommandUI {
    commandName         = "run",
845
    commandSynopsis     = "Builds and runs an executable.",
846
    commandDescription  = Just $ \pname -> wrapText $
847
848
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
849
850
851
852
      ++ "is built and executed.\n"
      ++ "\n"
      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "
      ++ "test-suite and get its full output.\n",
853
854
855
856
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " run\n"
       ++ "    Run the only executable in the current package;\n"
857
858
       ++ "  " ++ pname ++ " run foo -- --fooflag\n"
       ++ "    Works similar to `./foo --fooflag`.\n",
859
860
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
861
    commandDefaultFlags = mempty,
862
863
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
864
                          (commandOptions parent showOrParseArgs)
865
866
867
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
868
869
  }
  where
870
871
872
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

873
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
874

875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
-- ------------------------------------------------------------
-- * Report flags
-- ------------------------------------------------------------

data ReportFlags = ReportFlags {
    reportUsername  :: Flag Username,
    reportPassword  :: Flag Password,
    reportVerbosity :: Flag Verbosity
  }

defaultReportFlags :: ReportFlags
defaultReportFlags = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = toFlag normal
  }

reportCommand :: CommandUI ReportFlags
893
894
895
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
896
897
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
898
         "You can store your Hackage login in the ~/.cabal/config file\n",
899
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
    commandDefaultFlags = defaultReportFlags,
    commandOptions      = \_ ->
      [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })

      ,option ['u'] ["username"]
        "Hackage username."
        reportUsername (\v flags -> flags { reportUsername = v })
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))

      ,option ['p'] ["password"]
        "Hackage password."
        reportPassword (\v flags -> flags { reportPassword = v })
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
      ]
916
917
  }

918
919
920
921
922
923
924
925
926
927
928
929
930
instance Monoid ReportFlags where
  mempty = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = mempty
  }
  mappend a b = ReportFlags {
    reportUsername  = combine reportUsername,
    reportPassword  = combine reportPassword,
    reportVerbosity = combine reportVerbosity
  }
    where combine field = field a `mappend` field b

931
-- ------------------------------------------------------------
932
-- * Get flags
933
934
-- ------------------------------------------------------------

935
936
937
938
939
940
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
941

942
943
944
945
946
947
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
948
949
   }

950
951
952
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
953
954
    commandSynopsis     = "Download/Extract a package's source code (repository).",
    commandDescription  = Just $ \_ -> wrapText $
955
956
957
958
          "Creates a local copy of a package's source code. By default it gets "
       ++ "the source\ntarball and unpacks it in a local subdirectory. "
       ++ "Alternatively, with -s it will\nget the code from the source "
       ++ "repository specified by the package.\n",
959
960
961
962
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " get hlint\n"
       ++ "    Download the latest stable version of hlint;\n"
963
       ++ "  " ++ pname ++ " get lens --source-repository=head\n"
964
       ++ "    Download the source repository (i.e. git clone from github).\n",
965
    commandUsage        = usagePackages "get",
966
    commandDefaultFlags = defaultGetFlags,
967
    commandOptions      = \_ -> [
968
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
969
970

       ,option "d" ["destdir"]
refold's avatar
refold committed
971
         "Where to place the package source, defaults to the current directory."
972
         getDestDir (\v flags -> flags { getDestDir = v })
973
         (reqArgFlag "PATH")
974

975
       ,option "s" ["source-repository"]
976
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
977
978
979
980
981
982
         getSourceRepository (\v flags -> flags { getSourceRepository = v })
        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")
                                              (fmap (toFlag . Just) parse))
                                  (Flag Nothing)
                                  (map (fmap show) . flagToList))

983
984
985
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
986
           getPristine (\v flags -> flags { getPristine = v })
987
           trueArg
988
989
990
       ]
  }

991
992
993
994
995
996
997
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
unpackCommand = getCommand {
  commandName  = "unpack",
  commandUsage = usagePackages "unpack"
  }

998
instance Monoid GetFlags where
999
1000
  mempty = GetFlags {
    getDestDir          = mempty,