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
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
27
    , updateCommand
ijones's avatar
ijones committed
28
    , upgradeCommand
29
    , uninstallCommand
30
    , infoCommand, InfoFlags(..)
31
    , fetchCommand, FetchFlags(..)
32
    , freezeCommand, FreezeFlags(..)
33
    , getCommand, unpackCommand, GetFlags(..)
34
    , checkCommand
35
    , formatCommand
36
    , uploadCommand, UploadFlags(..)
37
    , reportCommand, ReportFlags(..)
refold's avatar
refold committed
38
    , runCommand
39
    , initCommand, IT.InitFlags(..)
40
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
41
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
42
    , actAsSetupCommand, ActAsSetupFlags(..)
refold's avatar
refold committed
43
    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
44
    , execCommand, ExecFlags(..)
45
    , userConfigCommand, UserConfigFlags(..)
Maciek Makowski's avatar
Maciek Makowski committed
46
    , manpageCommand
Duncan Coutts's avatar
Duncan Coutts committed
47
48

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

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

68

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

346
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
347
filterConfigureFlags flags cabalLibVersion
348
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
349
  -- ^ NB: we expect the latest version to be the most common case.
350
351
  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10
  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0
352
  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0
353
  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0
354
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
355
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
356
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
357
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
358
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
359
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
360
  | otherwise = flags_latest
361
  where
362
363
364
365
366
    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.
367
      configAllowNewer  = Just Cabal.AllowNewerNone
368
      }
369

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

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

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

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

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

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

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

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

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

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

470
471
472
  ]

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

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

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

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

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

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

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

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

541
542
543
544
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

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

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

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

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

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

591
-- ------------------------------------------------------------
592
-- * Fetch command
593
-- ------------------------------------------------------------
594

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

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

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

       ] ++

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

Duncan Coutts's avatar
Duncan Coutts committed
666
667
  }

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

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

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

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

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

732
733
734
735
736
737
738
739
       ] ++

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

  }

744
745
746
747
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

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

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

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

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

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

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

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

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

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

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

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

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

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

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

917
-- ------------------------------------------------------------
918
-- * Get flags
919
920
-- ------------------------------------------------------------

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

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

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

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

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

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

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

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

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

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

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