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

    , parsePackageArgs
50
51
52
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
53
    , readRepo
54
55
    ) where

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

69

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

109
import Data.Char
110
         ( isAlphaNum )
111
import Data.List
112
         ( intercalate, deleteFirstsBy )
113
import Data.Maybe
114
         ( maybeToList, fromMaybe )
115
116
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
117
118
119
120
121
122
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
123

124
125
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
126
    commandName         = "",
127
128
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
129
130
131
132
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
133
    commandDescription  = Just $ \pname ->
134
135
136
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
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
168
169
170
171
        -- 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"
          ]
172
173
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
174
175
176
177
178
179
180
181
182
        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
183
184
      in
         "Commands:\n"
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
217
218
219
220
      ++ 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"
221
        , addCmd "sandbox"
222
223
224
225
226
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
227
228
      ++ "\n"
      ++ "For more information about a command use:\n"
229
230
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
231
      ++ "\n"
232
      ++ "To install Cabal packages from hackage use:\n"
233
234
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
235
236
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
237
    commandNotes = Nothing,
238
    commandDefaultFlags = mempty,
239
240
241
242
243
244
245
246
247
248
249
    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"]
250
251
252
253
254
255
256
257
258
259
260
261
262
263
         "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")

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

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
269
270
      ,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
271
272
273
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

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

279
280
281
282
283
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

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

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

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

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

313
314
315
316
317
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

318
319
320
321
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
322
323
324
325
326
      ]

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

328
configureCommand :: CommandUI ConfigFlags
329
330
configureCommand = c
  { commandDefaultFlags = mempty
331
332
333
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
334
335
336
337
338
339
       ++ "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
340
  }
341
342
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
343

344
345
346
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

347
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
348
filterConfigureFlags flags cabalLibVersion
349
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
350
  -- ^ NB: we expect the latest version to be the most common case.
351
352
  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10
  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0
353
  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0
354
  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0
355
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
356
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
357
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
358
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
359
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
360
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
361
  | otherwise = flags_latest
362
  where
363
364
365
366
367
    flags_latest = flags        {
      -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
      configConstraints = [],
      -- Passing '--allow-newer' to Setup.hs is unnecessary, we use
      -- '--exact-configuration' instead.
368
      configAllowNewer  = Just Cabal.AllowNewerNone
369
      }
370

371
372
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
373
374
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
375

376
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
377
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
378

379
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
380
381
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
382
      flags_1_21_0 { configRelocatable = NoFlag
383
384
385
386
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
387
388
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
389
                   }
390
391
392
393
    -- 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 }
394
395
396
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
397
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
398
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
399
400
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
401
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
402
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
403
404
405
406
    -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'
    -- and '--enable/disable-library-coverage'.
    flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag
                                , configDynExe      = NoFlag }
407
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
408
    flags_1_10_0 = flags_1_12_0 { configTests       = NoFlag }
409
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
410
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
411

412
413
414
415
416
417
418
419
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
420
    configExConstraints:: [(UserConstraint, ConstraintSource)],
421
    configPreferences  :: [Dependency],
422
    configSolver       :: Flag PreSolver
423
  }
424
  deriving (Eq, Generic)
425
426

defaultConfigExFlags :: ConfigExFlags
427
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }
428
429
430
431
432

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
433
         liftOptions fst setFst
434
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
435
                  . optionName) $ configureOptions  showOrParseArgs)
436
437
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
438
439
440
441
442
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

443
444
445
446
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
447
448
449
450
451
452
453
  [ 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))
454
455
456
457
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
458
459
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
460
461
462
463

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
464
465
466
467
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
468
469

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

471
472
473
  ]

instance Monoid ConfigExFlags where
474
  mempty = gmempty
475
476
477
  mappend = (<>)

instance Semigroup ConfigExFlags where
478
  (<>) = gmappend
479

ttuegel's avatar
ttuegel committed
480
481
482
483
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

484
485
486
487
488
489
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
490
} deriving Generic
491
492
493

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
494
  option [] ["only"]
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
  "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
517
  mempty = gmempty
518
519
520
  mappend = (<>)

instance Semigroup BuildExFlags where
521
  (<>) = gmappend
522
523

-- ------------------------------------------------------------
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
-- * 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

542
543
544
545
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

546
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
547
testCommand = parent {
548
549
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
550
  commandOptions      =
551
    \showOrParseArgs -> liftOptions get1 set1
552
553
                        (commandOptions parent showOrParseArgs)
                        ++
554
555
556
557
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
558
559
  }
  where
560
561
562
    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)
563

564
565
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
566
567
568
569
570

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

571
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
572
benchmarkCommand = parent {
573
574
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
575
  commandOptions      =
576
    \showOrParseArgs -> liftOptions get1 set1
577
578
                        (commandOptions parent showOrParseArgs)
                        ++
579
580
581
582
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
583
  }
584
  where
585
586
587
    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)
588

589
590
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
591

592
-- ------------------------------------------------------------
593
-- * Fetch command
594
-- ------------------------------------------------------------
595

596
597
598
599
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
600
      fetchSolver           :: Flag PreSolver,
601
602
603
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
604
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
605
      fetchStrongFlags      :: Flag Bool,
606
607
608
609
610
611
612
613
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
614
615
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
616
    fetchReorderGoals     = Flag False,
617
    fetchIndependentGoals = Flag False,
618
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
619
    fetchStrongFlags      = Flag False,
620
621
622
623
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
624
625
fetchCommand = CommandUI {
    commandName         = "fetch",
626
    commandSynopsis     = "Downloads packages for later installation.",
627
628
629
630
631
    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",
632
    commandNotes        = Nothing,
633
    commandDefaultFlags = defaultFetchFlags,
634
    commandOptions      = \ showOrParseArgs -> [
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
         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
656
657
658
659

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
660
661
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
662
663
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
664
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
665
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
666

Duncan Coutts's avatar
Duncan Coutts committed
667
668
  }

669
670
671
672
673
674
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
675
676
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
677
678
679
680
681
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
682
      freezeStrongFlags      :: Flag Bool,
683
684
685
686
687
688
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
689
690
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
691
692
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
693
    freezeReorderGoals     = Flag False,
694
695
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
696
    freezeStrongFlags      = Flag False,
697
698
699
700
701
702
703
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
704
705
706
707
708
709
710
711
    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",
712
    commandNotes        = Nothing,
713
    commandUsage        = usageFlags "freeze",
714
715
716
717
718
719
720
721
722
    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

723
724
725
726
727
728
729
730
731
732
       , 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 [] [])

733
734
735
736
737
738
739
740
       ] ++

       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
741
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
742
743
744

  }

745
746
747
748
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

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

764
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
765
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
766
    commandName         = "upgrade",
767
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
768
    commandDescription  = Nothing,
refold's avatar
refold committed
769
    commandUsage        = usageFlagsOrPackages "upgrade",
770
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
771
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
772
773
  }

Duncan Coutts's avatar
Duncan Coutts committed
774
775
776
777
778
779
780
781
782
783
784
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

785
786
787
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
788
    commandSynopsis     = "Check the package for common mistakes.",
789
790
791
792
793
794
    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",
795
    commandNotes        = Nothing,
796
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
797
    commandDefaultFlags = toFlag normal,
798
    commandOptions      = \_ -> []
799
800
  }

801
802
803
804
805
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
806
    commandNotes        = Nothing,
807
    commandUsage        = usageAlternatives "format" ["[FILE]"],
808
809
810
811
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

812
813
814
815
816
817
818
819
820
821
822
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
823
824
825
826
827
828
829
830
831
832
833
834
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]
  }

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

866
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
867

868
869
870
871
872
873
874
875
-- ------------------------------------------------------------
-- * Report flags
-- ------------------------------------------------------------

data ReportFlags = ReportFlags {
    reportUsername  :: Flag Username,
    reportPassword  :: Flag Password,
    reportVerbosity :: Flag Verbosity
876
  } deriving Generic
877
878
879
880
881
882
883
884
885

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

reportCommand :: CommandUI ReportFlags
886
887
888
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
889
890
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
891
         "You can store your Hackage login in the ~/.cabal/config file\n",
892
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
    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))
      ]
909
910
  }

911
instance Monoid ReportFlags where
912
  mempty = gmempty
913
914
915
  mappend = (<>)

instance Semigroup ReportFlags where
916
  (<>) = gmappend
917

918
-- ------------------------------------------------------------
919
-- * Get flags
920
921
-- ------------------------------------------------------------

922
923
924
925
926
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
927
  } deriving Generic
928

929
930
931
932
933
934
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
935
936
   }

937
938
939
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
940
941
    commandSynopsis     = "Download/Extract a package's source code (repository).",
    commandDescription  = Just $ \_ -> wrapText $
942
943
944
945
          "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",
946
947
948
949
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " get hlint\n"
       ++ "    Download the latest stable version of hlint;\n"
950
       ++ "  " ++ pname ++ " get lens --source-repository=head\n"
951
       ++ "    Download the source repository (i.e. git clone from github).\n",
952
    commandUsage        = usagePackages "get",
953
    commandDefaultFlags = defaultGetFlags,
954
    commandOptions      = \_ -> [
955
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
956
957

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

962
       ,option "s" ["source-repository"]
963
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
964
965
966
967
968
969
         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))

970
971
972
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
973
           getPristine (\v flags -> flags { getPristine = v })
974
           trueArg
975
976
977
       ]
  }

978
979
980
981
982
983
984
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
unpackCommand = getCommand {
  commandName  = "unpack",
  commandUsage = usagePackages "unpack"
  }

985
instance Monoid GetFlags where
986
  mempty = gmempty
987
988
989
  mappend = (<>)

instance Semigroup GetFlags where
990
  (<>) = gmappend
991

992
993
994
995
996
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
997
    listInstalled    :: Flag Bool,
998
    listSimpleOutput :: Flag Bool,
999
1000
    listVerbosity    :: Flag Verbosity,
    listPackageDBs   :: [Maybe PackageDB]