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

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

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

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

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

114
115
116
117
118
119
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
120
121
122
123
    globalVersion           :: Flag Bool,
    globalNumericVersion    :: Flag Bool,
    globalConfigFile        :: Flag FilePath,
    globalSandboxConfigFile :: Flag FilePath,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
124
    globalConstraintsFile   :: Flag FilePath,
125
    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
126
    globalCacheDir          :: Flag FilePath,
127
    globalLocalRepos        :: NubList FilePath,
128
    globalLogsDir           :: Flag FilePath,
129
    globalWorldFile         :: Flag FilePath,
130
    globalRequireSandbox    :: Flag Bool,
131
    globalIgnoreSandbox     :: Flag Bool,
132
    globalIgnoreExpiry      :: Flag Bool,    -- ^ Ignore security expiry dates
133
    globalHttpTransport     :: Flag String
134
  }
Duncan Coutts's avatar
Duncan Coutts committed
135

136
137
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
138
139
140
141
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
142
    globalConstraintsFile   = mempty,
143
    globalRemoteRepos       = mempty,
144
145
146
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
147
    globalWorldFile         = mempty,
148
    globalRequireSandbox    = Flag False,
149
    globalIgnoreSandbox     = Flag False,
150
    globalIgnoreExpiry      = Flag False,
151
    globalHttpTransport     = mempty
152
153
  }

154
155
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
156
    commandName         = "",
157
158
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
159
160
161
162
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
163
    commandDescription  = Just $ \pname ->
164
165
166
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
        -- 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"
          ]
202
203
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
204
205
206
207
208
209
210
211
212
        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
213
214
      in
         "Commands:\n"
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
      ++ 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"
251
        , addCmd "sandbox"
252
253
254
255
256
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
257
258
      ++ "\n"
      ++ "For more information about a command use:\n"
259
260
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
261
      ++ "\n"
262
      ++ "To install Cabal packages from hackage use:\n"
263
264
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
265
266
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
267
    commandNotes = Nothing,
268
    commandDefaultFlags = mempty,
269
270
271
272
273
274
275
276
277
278
279
    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"]
280
281
282
283
284
285
286
287
288
289
290
291
292
293
         "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")

294
      ,option [] ["sandbox-config-file"]
295
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
296
297
298
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
299
300
      ,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
301
302
303
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

304
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
305
         "requiring the presence of a sandbox for sandbox-aware commands"
306
307
308
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

309
310
311
312
313
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

314
      ,option [] ["ignore-expiry"]
Edsko de Vries's avatar
Edsko de Vries committed
315
         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
316
317
318
         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
         trueArg

319
      ,option [] ["http-transport"]
320
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
321
322
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")
323
      ]
324

325
326
327
328
    -- arguments we don't want shown in the help
    argsNotShown :: [OptionField GlobalFlags]
    argsNotShown = [
       option [] ["remote-repo"]
329
330
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
331
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
332
333
334
335
336
337
338
339
340

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

343
344
345
346
347
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

348
349
350
351
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
352
353
354
355
      ]

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
356
357
358
359
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
360
    globalConstraintsFile   = mempty,
361
362
363
364
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
365
    globalWorldFile         = mempty,
366
    globalRequireSandbox    = mempty,
367
    globalIgnoreSandbox     = mempty,
368
    globalIgnoreExpiry      = mempty,
369
    globalHttpTransport     = mempty
370
371
  }
  mappend a b = GlobalFlags {
372
373
374
375
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
376
    globalConstraintsFile   = combine globalConstraintsFile,
377
378
379
380
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
381
    globalWorldFile         = combine globalWorldFile,
382
    globalRequireSandbox    = combine globalRequireSandbox,
383
    globalIgnoreSandbox     = combine globalIgnoreSandbox,
384
    globalIgnoreExpiry      = combine globalIgnoreExpiry,
385
    globalHttpTransport     = combine globalHttpTransport
Duncan Coutts's avatar
Duncan Coutts committed
386
  }
387
388
    where combine field = field a `mappend` field b

389
390
391
withGlobalRepos :: Verbosity -> GlobalFlags -> ([Repo] -> IO a) -> IO a
withGlobalRepos _verbosity globalFlags callback =
    callback $ remoteRepos ++ localRepos
392
393
  where
    remoteRepos =
Edsko de Vries's avatar
Edsko de Vries committed
394
      [ RepoRemote remote cacheDir
395
      | remote <- fromNubList $ globalRemoteRepos globalFlags
396
397
398
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
Edsko de Vries's avatar
Edsko de Vries committed
399
      [ RepoLocal local
400
      | local <- fromNubList $ globalLocalRepos globalFlags ]
401
402
403
404

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

406
configureCommand :: CommandUI ConfigFlags
407
408
configureCommand = c
  { commandDefaultFlags = mempty
409
410
411
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
412
413
414
415
416
417
       ++ "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
418
  }
419
420
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
421

422
423
424
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

425
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
426
filterConfigureFlags flags cabalLibVersion
427
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
428
  -- ^ NB: we expect the latest version to be the most common case.
429
430
431
  | 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
432
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
433
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
434
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
435
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
436
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
437
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
438
  | otherwise = flags_latest
439
  where
440
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
441
442
    flags_latest = flags        { configConstraints = [] }

443
444
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
445
446
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
447

448
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
449
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
450

451
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
452
453
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
454
      flags_1_21_0 { configRelocatable = NoFlag
455
456
457
458
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
459
460
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
461
                   }
462
463
464
465
    -- 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 }
466
467
468
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
469
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
470
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
471
472
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
473
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
474
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
475
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
476
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
477
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
478
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
479

480
481
482
483
484
485
486
487
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
488
    configExConstraints:: [(UserConstraint, ConstraintSource)],
489
    configPreferences  :: [Dependency],
490
491
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
492
493
494
  }

defaultConfigExFlags :: ConfigExFlags
495
496
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
497
498
499
500
501

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
502
         liftOptions fst setFst
503
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
504
                  . optionName) $ configureOptions  showOrParseArgs)
505
506
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
507
508
509
510
511
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

512
513
514
515
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
516
517
518
519
520
521
522
  [ 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))
523
524
525
526
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
527
528
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
529
530
531
532

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
533
534
535
536
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
537
538

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
541
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
542
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
543
    (optArg allowNewerArgument
544
545
546
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

547
  ]
cheecheeo's avatar
cheecheeo committed
548
  where allowNewerArgument = "DEPS"
549
550
551
552

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
553
    configExConstraints= mempty,
554
    configPreferences  = mempty,
555
556
    configSolver       = mempty,
    configAllowNewer   = mempty
557
558
559
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
560
    configExConstraints= combine configExConstraints,
561
    configPreferences  = combine configPreferences,
562
563
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
564
565
566
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
567
568
569
570
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

571
572
573
574
575
576
577
578
579
580
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
581
  option [] ["only"]
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
  "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

-- ------------------------------------------------------------
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
-- * 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

631
632
633
634
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

635
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
636
testCommand = parent {
637
638
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
639
  commandOptions      =
640
    \showOrParseArgs -> liftOptions get1 set1
641
642
                        (commandOptions parent showOrParseArgs)
                        ++
643
644
645
646
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
647
648
  }
  where
649
650
651
    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)
652

653
654
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
655
656
657
658
659

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

660
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
661
benchmarkCommand = parent {
662
663
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
664
  commandOptions      =
665
    \showOrParseArgs -> liftOptions get1 set1
666
667
                        (commandOptions parent showOrParseArgs)
                        ++
668
669
670
671
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
672
  }
673
  where
674
675
676
    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)
677

678
679
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
680

681
-- ------------------------------------------------------------
682
-- * Fetch command
683
-- ------------------------------------------------------------
684

685
686
687
688
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
689
      fetchSolver           :: Flag PreSolver,
690
691
692
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
693
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
694
      fetchStrongFlags      :: Flag Bool,
695
696
697
698
699
700
701
702
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
703
704
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
705
    fetchReorderGoals     = Flag False,
706
    fetchIndependentGoals = Flag False,
707
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
708
    fetchStrongFlags      = Flag False,
709
710
711
712
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
713
714
fetchCommand = CommandUI {
    commandName         = "fetch",
715
    commandSynopsis     = "Downloads packages for later installation.",
716
717
718
719
720
    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",
721
    commandNotes        = Nothing,
722
    commandDefaultFlags = defaultFetchFlags,
723
    commandOptions      = \ showOrParseArgs -> [
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
         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
745
746
747
748

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
749
750
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
751
752
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
753
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
754
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
755

Duncan Coutts's avatar
Duncan Coutts committed
756
757
  }

758
759
760
761
762
763
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
764
765
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
766
767
768
769
770
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
771
      freezeStrongFlags      :: Flag Bool,
772
773
774
775
776
777
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
778
779
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
780
781
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
782
    freezeReorderGoals     = Flag False,
783
784
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
785
    freezeStrongFlags      = Flag False,
786
787
788
789
790
791
792
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
793
794
795
796
797
798
799
800
    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",
801
    commandNotes        = Nothing,
802
    commandUsage        = usageFlags "freeze",
803
804
805
806
807
808
809
810
811
    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

812
813
814
815
816
817
818
819
820
821
       , 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 [] [])

822
823
824
825
826
827
828
829
       ] ++

       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
830
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
831
832
833

  }

834
835
836
837
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

838
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
839
840
updateCommand = CommandUI {
    commandName         = "update",
841
    commandSynopsis     = "Updates list of known packages.",
842
843
844
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
845
846
847
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
848
    commandUsage        = usageFlags "update",
849
    commandDefaultFlags = toFlag normal,
850
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
851
852
  }

853
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
854
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
855
    commandName         = "upgrade",
856
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
857
    commandDescription  = Nothing,
refold's avatar
refold committed
858
    commandUsage        = usageFlagsOrPackages "upgrade",
859
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
860
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
861
862
  }

Duncan Coutts's avatar
Duncan Coutts committed
863
864
865
866
867
868
869
870
871
872
873
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

874
875
876
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
877
    commandSynopsis     = "Check the package for common mistakes.",
878
879
880
881
882
883
    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",
884
    commandNotes        = Nothing,
885
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
886
    commandDefaultFlags = toFlag normal,
887
    commandOptions      = \_ -> []
888
889
  }

890
891
892
893
894
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
895
    commandNotes        = Nothing,
896
    commandUsage        = usageAlternatives "format" ["[FILE]"],
897
898
899
900
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

901
902
903
904
905
906
907
908
909
910
911
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
912
913
914
915
916
917
918
919
920
921
922
923
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]
  }

924
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
925
926
runCommand = CommandUI {
    commandName         = "run",
927
    commandSynopsis     = "Builds and runs an executable.",
928
    commandDescription  = Just $ \pname -> wrapText $
929
930
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
931
932
933
934
      ++ "is built and executed.\n"
      ++ "\n"
      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "
      ++ "test-suite and get its full output.\n",
935
936
937
938
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " run\n"
       ++ "    Run the only executable in the current package;\n"
939
940
       ++ "  " ++ pname ++ " run foo -- --fooflag\n"
       ++ "    Works similar to `./foo --fooflag`.\n",
941
942
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
943
    commandDefaultFlags = mempty,
944
945
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
946
                          (commandOptions parent showOrParseArgs)
947
948
949
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
950
951
  }
  where
952
953
954
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

955
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
956

957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
-- ------------------------------------------------------------
-- * 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
975
976
977
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
978
979
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
980
         "You can store your Hackage login in the ~/.cabal/config file\n",
981
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
    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))
      ]
998
999
  }

1000
instance Monoid ReportFlags where