Setup.hs 91.9 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
132
    globalIgnoreSandbox     :: Flag Bool,
    globalHttpTransport     :: Flag String
133
  }
Duncan Coutts's avatar
Duncan Coutts committed
134

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

152
153
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
154
    commandName         = "",
155
156
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
157
158
159
160
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
161
    commandDescription  = Just $ \pname ->
162
163
164
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
165
166
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
        -- 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"
          ]
200
201
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
202
203
204
205
206
207
208
209
210
        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
211
212
      in
         "Commands:\n"
213
214
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
      ++ 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"
249
        , addCmd "sandbox"
250
251
252
253
254
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
255
256
      ++ "\n"
      ++ "For more information about a command use:\n"
257
258
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
259
      ++ "\n"
260
      ++ "To install Cabal packages from hackage use:\n"
261
262
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
263
264
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
265
    commandNotes = Nothing,
266
    commandDefaultFlags = mempty,
267
268
269
270
271
272
273
274
275
276
277
    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"]
278
279
280
281
282
283
284
285
286
287
288
289
290
291
         "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")

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

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

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

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

312
      ,option [] ["http-transport"]
313
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
314
315
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")
316
      ]
317

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

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

336
337
338
339
340
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

341
342
343
344
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
345
346
347
348
      ]

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
349
350
351
352
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
353
    globalConstraintsFile   = mempty,
354
355
356
357
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
358
    globalWorldFile         = mempty,
359
    globalRequireSandbox    = mempty,
360
361
    globalIgnoreSandbox     = mempty,
    globalHttpTransport     = mempty
362
363
  }
  mappend a b = GlobalFlags {
364
365
366
367
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
368
    globalConstraintsFile   = combine globalConstraintsFile,
369
370
371
372
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
373
    globalWorldFile         = combine globalWorldFile,
374
    globalRequireSandbox    = combine globalRequireSandbox,
375
376
    globalIgnoreSandbox     = combine globalIgnoreSandbox,
    globalHttpTransport     = combine globalHttpTransport
Duncan Coutts's avatar
Duncan Coutts committed
377
  }
378
379
    where combine field = field a `mappend` field b

380
381
382
withGlobalRepos :: Verbosity -> GlobalFlags -> ([Repo] -> IO a) -> IO a
withGlobalRepos _verbosity globalFlags callback =
    callback $ remoteRepos ++ localRepos
383
384
  where
    remoteRepos =
Edsko de Vries's avatar
Edsko de Vries committed
385
      [ RepoRemote remote cacheDir
386
      | remote <- fromNubList $ globalRemoteRepos globalFlags
387
388
389
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
Edsko de Vries's avatar
Edsko de Vries committed
390
      [ RepoLocal local
391
      | local <- fromNubList $ globalLocalRepos globalFlags ]
392
393
394
395

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

397
configureCommand :: CommandUI ConfigFlags
398
399
configureCommand = c
  { commandDefaultFlags = mempty
400
401
402
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
403
404
405
406
407
408
       ++ "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
409
  }
410
411
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
412

413
414
415
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

416
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
417
filterConfigureFlags flags cabalLibVersion
418
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
419
  -- ^ NB: we expect the latest version to be the most common case.
420
421
422
  | 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
423
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
424
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
425
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
426
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
427
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
428
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
429
  | otherwise = flags_latest
430
  where
431
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
432
433
    flags_latest = flags        { configConstraints = [] }

434
435
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
436
437
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
438

439
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
440
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
441

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

471
472
473
474
475
476
477
478
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
479
    configExConstraints:: [(UserConstraint, ConstraintSource)],
480
    configPreferences  :: [Dependency],
481
482
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
483
484
485
  }

defaultConfigExFlags :: ConfigExFlags
486
487
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
488
489
490
491
492

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
493
         liftOptions fst setFst
494
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
495
                  . optionName) $ configureOptions  showOrParseArgs)
496
497
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
498
499
500
501
502
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

503
504
505
506
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
507
508
509
510
511
512
513
  [ 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))
514
515
516
517
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
518
519
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
520
521
522
523

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
524
525
526
527
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
528
529

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
532
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
533
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
534
    (optArg allowNewerArgument
535
536
537
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

538
  ]
cheecheeo's avatar
cheecheeo committed
539
  where allowNewerArgument = "DEPS"
540
541
542
543

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
544
    configExConstraints= mempty,
545
    configPreferences  = mempty,
546
547
    configSolver       = mempty,
    configAllowNewer   = mempty
548
549
550
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
551
    configExConstraints= combine configExConstraints,
552
    configPreferences  = combine configPreferences,
553
554
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
555
556
557
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
558
559
560
561
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

562
563
564
565
566
567
568
569
570
571
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
572
  option [] ["only"]
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
  "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

-- ------------------------------------------------------------
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
-- * 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

622
623
624
625
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

626
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
627
testCommand = parent {
628
629
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
630
  commandOptions      =
631
    \showOrParseArgs -> liftOptions get1 set1
632
633
                        (commandOptions parent showOrParseArgs)
                        ++
634
635
636
637
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
638
639
  }
  where
640
641
642
    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)
643

644
645
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
646
647
648
649
650

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

651
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
652
benchmarkCommand = parent {
653
654
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
655
  commandOptions      =
656
    \showOrParseArgs -> liftOptions get1 set1
657
658
                        (commandOptions parent showOrParseArgs)
                        ++
659
660
661
662
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
663
  }
664
  where
665
666
667
    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)
668

669
670
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
671

672
-- ------------------------------------------------------------
673
-- * Fetch command
674
-- ------------------------------------------------------------
675

676
677
678
679
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
680
      fetchSolver           :: Flag PreSolver,
681
682
683
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
684
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
685
      fetchStrongFlags      :: Flag Bool,
686
687
688
689
690
691
692
693
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
694
695
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
696
    fetchReorderGoals     = Flag False,
697
    fetchIndependentGoals = Flag False,
698
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
699
    fetchStrongFlags      = Flag False,
700
701
702
703
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
704
705
fetchCommand = CommandUI {
    commandName         = "fetch",
706
    commandSynopsis     = "Downloads packages for later installation.",
707
708
709
710
711
    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",
712
    commandNotes        = Nothing,
713
    commandDefaultFlags = defaultFetchFlags,
714
    commandOptions      = \ showOrParseArgs -> [
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
         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
736
737
738
739

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
740
741
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
742
743
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
744
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
745
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
746

Duncan Coutts's avatar
Duncan Coutts committed
747
748
  }

749
750
751
752
753
754
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
755
756
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
757
758
759
760
761
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
762
      freezeStrongFlags      :: Flag Bool,
763
764
765
766
767
768
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
769
770
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
771
772
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
773
    freezeReorderGoals     = Flag False,
774
775
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
776
    freezeStrongFlags      = Flag False,
777
778
779
780
781
782
783
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
784
785
786
787
788
789
790
791
    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",
792
    commandNotes        = Nothing,
793
    commandUsage        = usageFlags "freeze",
794
795
796
797
798
799
800
801
802
    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

803
804
805
806
807
808
809
810
811
812
       , 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 [] [])

813
814
815
816
817
818
819
820
       ] ++

       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
821
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
822
823
824

  }

825
826
827
828
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

829
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
830
831
updateCommand = CommandUI {
    commandName         = "update",
832
    commandSynopsis     = "Updates list of known packages.",
833
834
835
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
836
837
838
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
839
    commandUsage        = usageFlags "update",
840
    commandDefaultFlags = toFlag normal,
841
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
842
843
  }

844
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
845
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
846
    commandName         = "upgrade",
847
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
848
    commandDescription  = Nothing,
refold's avatar
refold committed
849
    commandUsage        = usageFlagsOrPackages "upgrade",
850
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
851
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
852
853
  }

Duncan Coutts's avatar
Duncan Coutts committed
854
855
856
857
858
859
860
861
862
863
864
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

865
866
867
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
868
    commandSynopsis     = "Check the package for common mistakes.",
869
870
871
872
873
874
    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",
875
    commandNotes        = Nothing,
876
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
877
    commandDefaultFlags = toFlag normal,
878
    commandOptions      = \_ -> []
879
880
  }

881
882
883
884
885
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
886
    commandNotes        = Nothing,
887
    commandUsage        = usageAlternatives "format" ["[FILE]"],
888
889
890
891
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

892
893
894
895
896
897
898
899
900
901
902
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
903
904
905
906
907
908
909
910
911
912
913
914
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]
  }

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

946
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
947

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

991
992
993
994
995
996
997
998
999
1000
instance Monoid ReportFlags where
  mempty = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = mempty
  }
  mappend a b = ReportFlags {
    reportUsername  = combine reportUsername,
    reportPassword  = combine reportPassword,
    reportVerbosity = combine reportVerbosity