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

    , parsePackageArgs
40
41
42
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
43
44
    ) where

45
import Distribution.Client.Types
46
         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )
47
48
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
49
import Distribution.Client.Dependency.Types
50
         ( AllowNewer(..), PreSolver(..) )
51
52
import qualified Distribution.Client.Init.Types as IT
         ( InitFlags(..), PackageType(..) )
53
54
import Distribution.Client.Targets
         ( UserConstraint, readUserConstraint )
55
56
import Distribution.Utils.NubList
         ( NubList, toNubList, fromNubList)
57

58
import Distribution.Simple.Compiler (PackageDB)
59
60
import Distribution.Simple.Program
         ( defaultProgramConfiguration )
61
62
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
Duncan Coutts's avatar
Duncan Coutts committed
63
import qualified Distribution.Simple.Setup as Cabal
64
import Distribution.Simple.Setup
65
66
         ( ConfigFlags(..), BuildFlags(..), ReplFlags
         , TestFlags(..), BenchmarkFlags(..)
67
         , SDistFlags(..), HaddockFlags(..)
68
         , readPackageDbList, showPackageDbList
69
         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
70
         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs )
71
import Distribution.Simple.InstallDirs
72
73
         ( PathTemplate, InstallDirs(sysconfdir)
         , toPathTemplate, fromPathTemplate )
74
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
75
         ( Version(Version), anyVersion, thisVersion )
76
import Distribution.Package
77
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
78
79
import Distribution.PackageDescription
         ( RepoKind(..) )
80
import Distribution.Text
81
         ( Text(..), display )
82
import Distribution.ReadE
83
         ( ReadE(..), readP_to_E, succeedReadE )
84
import qualified Distribution.Compat.ReadP as Parse
85
         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )
86
87
import Distribution.Verbosity
         ( Verbosity, normal )
88
89
import Distribution.Simple.Utils
         ( wrapText )
90

91
92
import Data.Char
         ( isSpace, isAlphaNum )
93
94
import Data.List
         ( intercalate )
95
import Data.Maybe
96
         ( listToMaybe, maybeToList, fromMaybe )
97
98
99
100
101
102
103
104
import Data.Monoid
         ( Monoid(..) )
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
105

106
107
108
109
110
111
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
112
113
114
115
    globalVersion           :: Flag Bool,
    globalNumericVersion    :: Flag Bool,
    globalConfigFile        :: Flag FilePath,
    globalSandboxConfigFile :: Flag FilePath,
116
    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
117
    globalCacheDir          :: Flag FilePath,
118
    globalLocalRepos        :: NubList FilePath,
119
    globalLogsDir           :: Flag FilePath,
120
    globalWorldFile         :: Flag FilePath,
121
122
    globalRequireSandbox    :: Flag Bool,
    globalIgnoreSandbox     :: Flag Bool
123
  }
Duncan Coutts's avatar
Duncan Coutts committed
124

125
126
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
127
128
129
130
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
131
    globalRemoteRepos       = mempty,
132
133
134
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
135
    globalWorldFile         = mempty,
136
137
    globalRequireSandbox    = Flag False,
    globalIgnoreSandbox     = Flag False
138
139
140
141
142
143
  }

globalCommand :: CommandUI GlobalFlags
globalCommand = CommandUI {
    commandName         = "",
    commandSynopsis     = "",
144
145
146
147
    commandUsage        = \_ ->
         "This program is the command line interface "
           ++ "to the Haskell Cabal infrastructure.\n"
      ++ "See http://www.haskell.org/cabal/ for more information.\n",
148
    commandDescription  = Just $ \pname ->
149
150
151
152
153
154
         "For more information about a command use:\n"
      ++ "  " ++ pname ++ " COMMAND --help\n\n"
      ++ "To install Cabal packages from hackage use:\n"
      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
155
    commandDefaultFlags = mempty,
156
    commandOptions      = \showOrParseArgs ->
157
      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
      [option ['V'] ["version"]
         "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")

173
174
175
176
177
178
      ,option [] ["sandbox-config-file"]
         "Set an alternate location for the sandbox config file \
         \(default: './cabal.sandbox.config')"
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

179
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
180
         "requiring the presence of a sandbox for sandbox-aware commands"
181
182
183
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

184
185
186
187
188
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

189
190
191
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
192
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
193
194
195
196
197
198
199
200
201

      ,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 })
202
         (reqArg' "DIR" (\x -> toNubList [x]) fromNubList)
203

204
205
206
207
208
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

209
210
211
212
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
213
214
215
216
217
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
218
219
220
221
222
223
224
225
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
226
    globalWorldFile         = mempty,
227
228
    globalRequireSandbox    = mempty,
    globalIgnoreSandbox     = mempty
229
230
  }
  mappend a b = GlobalFlags {
231
232
233
234
235
236
237
238
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
239
    globalWorldFile         = combine globalWorldFile,
240
241
    globalRequireSandbox    = combine globalRequireSandbox,
    globalIgnoreSandbox     = combine globalIgnoreSandbox
Duncan Coutts's avatar
Duncan Coutts committed
242
  }
243
244
245
246
247
248
249
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
250
      | remote <- fromNubList $ globalRemoteRepos globalFlags
251
252
253
254
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
255
      | local <- fromNubList $ globalLocalRepos globalFlags ]
256
257
258
259

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

261
configureCommand :: CommandUI ConfigFlags
262
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
263
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
264
265
  }

266
267
268
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

269
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
270
filterConfigureFlags flags cabalLibVersion
271
  | cabalLibVersion >= Version [1,19,2] [] = flags_latest
272
273
274
  | 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
275
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
276
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
277
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
278
  | otherwise = flags_latest
279
  where
280
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
281
282
    flags_latest = flags        { configConstraints = [] }

283
284
285
286
287
    -- Cabal < 1.19.2 doesn't know about '--exact-configuration'.
    flags_1_19_1 = flags_latest { configExactConfiguration = NoFlag }
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
288
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
289
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
290
291
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
292
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
293
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
294
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
295
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
296
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
297
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
298

299
300
301
302
303
304
305
306
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
307
    configExConstraints:: [UserConstraint],
308
    configPreferences  :: [Dependency],
309
310
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
311
312
313
  }

defaultConfigExFlags :: ConfigExFlags
314
315
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
316
317
318
319
320

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
321
         liftOptions fst setFst
322
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
323
                  . optionName) $ configureOptions  showOrParseArgs)
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs =
  [ 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))
339
340
341
342
343
344
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
              (fmap (\x -> [x]) (ReadE readUserConstraint))
              (map display))
345
346
347
348

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
349
350
351
352
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
353
354

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
355
356

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
357
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
358
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
359
    (optArg allowNewerArgument
360
361
362
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

363
  ]
cheecheeo's avatar
cheecheeo committed
364
  where allowNewerArgument = "DEPS"
365
366
367
368

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
369
    configExConstraints= mempty,
370
    configPreferences  = mempty,
371
372
    configSolver       = mempty,
    configAllowNewer   = mempty
373
374
375
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
376
    configExConstraints= combine configExConstraints,
377
    configPreferences  = combine configPreferences,
378
379
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
380
381
382
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
383
384
385
386
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

387
388
389
390
391
392
393
394
395
396
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
397
  option [] ["only"]
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
  "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

-- ------------------------------------------------------------
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
-- * 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

447
448
449
450
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

451
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
452
testCommand = parent {
453
454
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
455
  commandOptions      =
456
    \showOrParseArgs -> liftOptions get1 set1
457
458
                        (commandOptions parent showOrParseArgs)
                        ++
459
460
461
462
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
463
464
  }
  where
465
466
467
    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)
468

469
470
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
471
472
473
474
475

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

476
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
477
benchmarkCommand = parent {
478
479
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
480
  commandOptions      =
481
    \showOrParseArgs -> liftOptions get1 set1
482
483
                        (commandOptions parent showOrParseArgs)
                        ++
484
485
486
487
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
488
  }
489
  where
490
491
492
    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)
493

494
495
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
496

497
-- ------------------------------------------------------------
498
-- * Fetch command
499
-- ------------------------------------------------------------
500

501
502
503
504
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
505
      fetchSolver           :: Flag PreSolver,
506
507
508
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
509
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
510
      fetchStrongFlags      :: Flag Bool,
511
512
513
514
515
516
517
518
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
519
520
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
521
    fetchReorderGoals     = Flag False,
522
    fetchIndependentGoals = Flag False,
523
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
524
    fetchStrongFlags      = Flag False,
525
526
527
528
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
529
530
fetchCommand = CommandUI {
    commandName         = "fetch",
531
    commandSynopsis     = "Downloads packages for later installation.",
Duncan Coutts's avatar
Duncan Coutts committed
532
    commandDescription  = Nothing,
refold's avatar
refold committed
533
    commandUsage        = usagePackages "fetch",
534
    commandDefaultFlags = defaultFetchFlags,
535
    commandOptions      = \ showOrParseArgs -> [
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
         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
557
558
559
560

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
561
562
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
563
564
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
565
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
566
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
567

Duncan Coutts's avatar
Duncan Coutts committed
568
569
  }

570
571
572
573
574
575
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
576
577
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
578
579
580
581
582
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
583
      freezeStrongFlags      :: Flag Bool,
584
585
586
587
588
589
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
590
591
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
592
593
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
594
    freezeReorderGoals     = Flag False,
595
596
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
597
    freezeStrongFlags      = Flag False,
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "freeze",
    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

616
617
618
619
620
621
622
623
624
625
       , 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 [] [])

626
627
628
629
630
631
632
633
       ] ++

       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
634
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
635
636
637

  }

638
639
640
641
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

642
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
643
644
updateCommand = CommandUI {
    commandName         = "update",
645
    commandSynopsis     = "Updates list of known packages.",
Duncan Coutts's avatar
Duncan Coutts committed
646
    commandDescription  = Nothing,
refold's avatar
refold committed
647
    commandUsage        = usageFlags "update",
648
    commandDefaultFlags = toFlag normal,
649
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
650
651
  }

652
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
653
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
654
    commandName         = "upgrade",
655
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
656
    commandDescription  = Nothing,
refold's avatar
refold committed
657
    commandUsage        = usageFlagsOrPackages "upgrade",
658
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
659
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
660
661
  }

Duncan Coutts's avatar
Duncan Coutts committed
662
663
664
665
666
667
668
669
670
671
672
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

673
674
675
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
676
    commandSynopsis     = "Check the package for common mistakes.",
677
678
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
679
    commandDefaultFlags = toFlag normal,
680
    commandOptions      = \_ -> []
681
682
  }

683
684
685
686
687
688
689
690
691
692
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " format [FILE]\n",
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

693
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
694
695
696
697
698
runCommand = CommandUI {
    commandName         = "run",
    commandSynopsis     = "Runs the compiled executable.",
    commandDescription  = Nothing,
    commandUsage        =
699
700
701
      \pname -> "Usage: " ++ pname
                ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"
                ++ "Flags for run:",
refold's avatar
refold committed
702
    commandDefaultFlags = mempty,
703
704
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
705
                          (commandOptions parent showOrParseArgs)
706
707
708
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
709
710
  }
  where
711
712
713
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

714
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
715

716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
-- ------------------------------------------------------------
-- * 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
734
735
736
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
    commandDescription  = Just $ \_ ->
         "You can store your Hackage login in the ~/.cabal/config file\n",
    commandUsage        = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"
      ++ "Flags for upload:",
    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))
      ]
757
758
  }

759
760
761
762
763
764
765
766
767
768
769
770
771
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

772
-- ------------------------------------------------------------
773
-- * Get flags
774
775
-- ------------------------------------------------------------

776
777
778
779
780
781
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
782

783
784
785
786
787
788
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
789
790
   }

791
792
793
794
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
    commandSynopsis     = "Gets a package's source code.",
795
796
797
798
799
    commandDescription  = Just $ \_ ->
          "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",
800
    commandUsage        = usagePackages "get",
801
    commandDefaultFlags = defaultGetFlags,
802
    commandOptions      = \_ -> [
803
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
804
805

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

810
       ,option "s" ["source-repository"]
811
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
812
813
814
815
816
817
         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))

818
819
820
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
821
           getPristine (\v flags -> flags { getPristine = v })
822
           trueArg
823
824
825
       ]
  }

826
827
828
829
830
831
832
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
unpackCommand = getCommand {
  commandName  = "unpack",
  commandUsage = usagePackages "unpack"
  }

833
instance Monoid GetFlags where
834
835
836
837
838
839
  mempty = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = mempty
    }
840
841
842
843
844
  mappend a b = GetFlags {
    getDestDir          = combine getDestDir,
    getPristine         = combine getPristine,
    getSourceRepository = combine getSourceRepository,
    getVerbosity        = combine getVerbosity
845
846
847
  }
    where combine field = field a `mappend` field b

848
849
850
851
852
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
853
    listInstalled    :: Flag Bool,
854
    listSimpleOutput :: Flag Bool,
855
856
    listVerbosity    :: Flag Verbosity,
    listPackageDBs   :: [Maybe PackageDB]
857
858
859
860
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
861
    listInstalled    = Flag False,
862
    listSimpleOutput = Flag False,
863
864
    listVerbosity    = toFlag normal,
    listPackageDBs   = []
865
866
867
868
869
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
870
    commandSynopsis     = "List packages matching a search string.",
871
    commandDescription  = Nothing,
refold's avatar
refold committed
872
    commandUsage        = usageFlagsOrPackages "list",
873
    commandDefaultFlags = defaultListFlags,
874
    commandOptions      = \_ -> [
875
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
876

877
        , option [] ["installed"]
878
879
880
881
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

882
883
884
885
886
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

887
888
889
890
891
        , option "" ["package-db"]
          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
          listPackageDBs (\v flags -> flags { listPackageDBs = v })
          (reqArg' "DB" readPackageDbList showPackageDbList)

892
893
894
895
        ]
  }

instance Monoid ListFlags where
896
897
898
899
900
901
  mempty = ListFlags {
    listInstalled    = mempty,
    listSimpleOutput = mempty,
    listVerbosity    = mempty,
    listPackageDBs   = mempty
    }
902
  mappend a b = ListFlags {
903
    listInstalled    = combine listInstalled,
904
    listSimpleOutput = combine listSimpleOutput,
905
906
    listVerbosity    = combine listVerbosity,
    listPackageDBs   = combine listPackageDBs
907
908
909
  }
    where combine field = field a `mappend` field b

910
911
912
913
914
-- ------------------------------------------------------------
-- * Info flags
-- ------------------------------------------------------------

data InfoFlags = InfoFlags {
915
916
    infoVerbosity  :: Flag Verbosity,
    infoPackageDBs :: [Maybe PackageDB]
917
918
919
920
  }

defaultInfoFlags :: InfoFlags
defaultInfoFlags = InfoFlags {
921
922
    infoVerbosity  = toFlag normal,
    infoPackageDBs = []
923
924
925
926
927
928
929
  }

infoCommand  :: CommandUI InfoFlags
infoCommand = CommandUI {
    commandName         = "info",
    commandSynopsis     = "Display detailed information about a particular package.",
    commandDescription  = Nothing,
refold's avatar
refold committed
930
    commandUsage        = usagePackages "info",
931
932
933
    commandDefaultFlags = defaultInfoFlags,
    commandOptions      = \_ -> [
        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })
934
935
936
937
938
939

        , option "" ["package-db"]
          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
          infoPackageDBs (\v flags -> flags { infoPackageDBs = v })
          (reqArg' "DB" readPackageDbList showPackageDbList)

940
941
942
943
        ]
  }

instance Monoid InfoFlags where
944
945
946
947
  mempty = InfoFlags {
    infoVerbosity  = mempty,
    infoPackageDBs = mempty
    }
948
  mappend a b = InfoFlags {
949
950
    infoVerbosity  = combine infoVerbosity,
    infoPackageDBs = combine infoPackageDBs
951
952
953
  }
    where combine field = field a `mappend` field b

954
955
956
957
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

958
959
-- | Install takes the same flags as configure along with a few extras.
--
960
data InstallFlags = InstallFlags {
961
962
963
    installDocumentation    :: Flag Bool,
    installHaddockIndex     :: Flag PathTemplate,
    installDryRun           :: Flag Bool,
964
965
966
    installMaxBackjumps     :: Flag Int,
    installReorderGoals     :: Flag Bool,
    installIndependentGoals :: Flag Bool,
967
    installShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
968
    installStrongFlags      :: Flag Bool,
969
970
    installReinstall        :: Flag Bool,
    installAvoidReinstalls  :: Flag Bool,
971
    installOverrideReinstall :: Flag Bool,
972
973
974
975
    installUpgradeDeps      :: Flag Bool,
    installOnly             :: Flag Bool,
    installOnlyDeps         :: Flag Bool,
    installRootCmd          :: Flag String,
976
    installSummaryFile      :: NubList PathTemplate,
977
978
    installLogFile          :: Flag PathTemplate,
    installBuildReports     :: Flag ReportLevel,
979
    installReportPlanningFailure :: Flag Bool,
980
    installSymlinkBinDir    :: Flag FilePath,
981
    installOneShot          :: Flag Bool,
982
983
    installNumJobs          :: Flag (Maybe Int),
    installRunTests         :: Flag Bool
984
985
986
987
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
988
989
990
    installDocumentation   = Flag False,
    installHaddockIndex    = Flag docIndexFile,
    installDryRun          = Flag False,
991
    installMaxBackjumps    = Flag defaultMaxBackjumps,
992
    installReorderGoals    = Flag False,
993
    installIndependentGoals= Flag False,
994
    installShadowPkgs      = Flag False,
Andres Löh's avatar
Andres Löh committed
995
    installStrongFlags     = Flag False,
996
997
    installReinstall       = Flag False,
    installAvoidReinstalls = Flag False,
998
    installOverrideReinstall = Flag False,
999
1000
    installUpgradeDeps     = Flag False,
    installOnly            = Flag False,