Setup.hs 89.2 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, globalRepos
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(..)
Duncan Coutts's avatar
Duncan Coutts committed
42
43

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

50
import Distribution.Client.Types
51
         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )
52
53
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
54
import Distribution.Client.Dependency.Types
55
         ( AllowNewer(..), PreSolver(..) )
56
57
import qualified Distribution.Client.Init.Types as IT
         ( InitFlags(..), PackageType(..) )
58
59
import Distribution.Client.Targets
         ( UserConstraint, readUserConstraint )
60
61
import Distribution.Utils.NubList
         ( NubList, toNubList, fromNubList)
62

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

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

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

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
119
120
121
122
    globalVersion           :: Flag Bool,
    globalNumericVersion    :: Flag Bool,
    globalConfigFile        :: Flag FilePath,
    globalSandboxConfigFile :: Flag FilePath,
123
    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
124
    globalCacheDir          :: Flag FilePath,
125
    globalLocalRepos        :: NubList FilePath,
126
    globalLogsDir           :: Flag FilePath,
127
    globalWorldFile         :: Flag FilePath,
128
129
    globalRequireSandbox    :: Flag Bool,
    globalIgnoreSandbox     :: Flag Bool
130
  }
Duncan Coutts's avatar
Duncan Coutts committed
131

132
133
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
134
135
136
137
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
138
    globalRemoteRepos       = mempty,
139
140
141
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
142
    globalWorldFile         = mempty,
143
144
    globalRequireSandbox    = Flag False,
    globalIgnoreSandbox     = Flag False
145
146
  }

147
148
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
149
    commandName         = "",
150
151
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
152
153
154
155
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
156
    commandDescription  = Just $ \pname ->
157
158
159
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
160
161
162
163
164
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
        -- 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"
          ]
195
196
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
197
198
199
200
201
202
203
204
205
        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
206
207
      in
         "Commands:\n"
208
209
210
211
212
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
      ++ 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"
244
        , addCmd "sandbox"
245
246
247
248
249
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
250
251
      ++ "\n"
      ++ "For more information about a command use:\n"
252
253
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
254
      ++ "\n"
255
      ++ "To install Cabal packages from hackage use:\n"
256
257
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
258
259
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
260
    commandNotes = Nothing,
261
    commandDefaultFlags = mempty,
262
    commandOptions      = \showOrParseArgs ->
263
      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
      [option ['V'] ["version"]
         "Print version information"
         globalVersion (\v flags -> flags { globalVersion = v })
         trueArg

      ,option [] ["numeric-version"]
         "Print just the version number"
         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })
         trueArg

      ,option [] ["config-file"]
         "Set an alternate location for the config file"
         globalConfigFile (\v flags -> flags { globalConfigFile = v })
         (reqArgFlag "FILE")

279
      ,option [] ["sandbox-config-file"]
280
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
281
282
283
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

284
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
285
         "requiring the presence of a sandbox for sandbox-aware commands"
286
287
288
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

289
290
291
292
293
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

294
295
296
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
297
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
298
299
300
301
302
303
304
305
306

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

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

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

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
323
324
325
326
327
328
329
330
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
331
    globalWorldFile         = mempty,
332
333
    globalRequireSandbox    = mempty,
    globalIgnoreSandbox     = mempty
334
335
  }
  mappend a b = GlobalFlags {
336
337
338
339
340
341
342
343
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
344
    globalWorldFile         = combine globalWorldFile,
345
346
    globalRequireSandbox    = combine globalRequireSandbox,
    globalIgnoreSandbox     = combine globalIgnoreSandbox
Duncan Coutts's avatar
Duncan Coutts committed
347
  }
348
349
350
351
352
353
354
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
355
      | remote <- fromNubList $ globalRemoteRepos globalFlags
356
357
358
359
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
360
      | local <- fromNubList $ globalLocalRepos globalFlags ]
361
362
363
364

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

366
configureCommand :: CommandUI ConfigFlags
367
368
configureCommand = c
  { commandDefaultFlags = mempty
369
370
371
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
372
373
374
375
376
377
       ++ "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
378
  }
379
380
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
381

382
383
384
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

385
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
386
filterConfigureFlags flags cabalLibVersion
387
  | cabalLibVersion >= Version [1,22,0] [] = flags_latest
388
  -- ^ NB: we expect the latest version to be the most common case.
389
390
391
  | 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
392
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
393
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
394
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
395
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
396
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
397
  | otherwise = flags_latest
398
  where
399
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
400
401
    flags_latest = flags        { configConstraints = [] }

402
403
404
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
    flags_1_21_0 = flags_latest { configDebugInfo = NoFlag }

405
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
406
407
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
408
      flags_1_21_0 { configRelocatable = NoFlag
409
410
411
412
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
413
414
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
415
                   }
416
417
418
419
    -- 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 }
420
421
422
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
423
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
424
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
425
426
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
427
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
428
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
429
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
430
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
431
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
432
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
433

434
435
436
437
438
439
440
441
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
442
    configExConstraints:: [UserConstraint],
443
    configPreferences  :: [Dependency],
444
445
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
446
447
448
  }

defaultConfigExFlags :: ConfigExFlags
449
450
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
451
452
453
454
455

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
456
         liftOptions fst setFst
457
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
458
                  . optionName) $ configureOptions  showOrParseArgs)
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs =
  [ option [] ["cabal-lib-version"]
      ("Select which version of the Cabal lib to use to build packages "
      ++ "(useful for testing).")
      configCabalVersion (\v flags -> flags { configCabalVersion = v })
      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
                                    (fmap toFlag parse))
                        (map display . flagToList))
474
475
476
477
478
479
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
              (fmap (\x -> [x]) (ReadE readUserConstraint))
              (map display))
480
481
482
483

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
484
485
486
487
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
488
489

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
492
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
493
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
494
    (optArg allowNewerArgument
495
496
497
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

498
  ]
cheecheeo's avatar
cheecheeo committed
499
  where allowNewerArgument = "DEPS"
500
501
502
503

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
504
    configExConstraints= mempty,
505
    configPreferences  = mempty,
506
507
    configSolver       = mempty,
    configAllowNewer   = mempty
508
509
510
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
511
    configExConstraints= combine configExConstraints,
512
    configPreferences  = combine configPreferences,
513
514
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
515
516
517
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
518
519
520
521
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

522
523
524
525
526
527
528
529
530
531
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
532
  option [] ["only"]
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
  "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

-- ------------------------------------------------------------
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
-- * 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

582
583
584
585
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

586
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
587
testCommand = parent {
588
589
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
590
  commandOptions      =
591
    \showOrParseArgs -> liftOptions get1 set1
592
593
                        (commandOptions parent showOrParseArgs)
                        ++
594
595
596
597
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
598
599
  }
  where
600
601
602
    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)
603

604
605
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
606
607
608
609
610

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

611
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
612
benchmarkCommand = parent {
613
614
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
615
  commandOptions      =
616
    \showOrParseArgs -> liftOptions get1 set1
617
618
                        (commandOptions parent showOrParseArgs)
                        ++
619
620
621
622
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
623
  }
624
  where
625
626
627
    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)
628

629
630
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
631

632
-- ------------------------------------------------------------
633
-- * Fetch command
634
-- ------------------------------------------------------------
635

636
637
638
639
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
640
      fetchSolver           :: Flag PreSolver,
641
642
643
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
644
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
645
      fetchStrongFlags      :: Flag Bool,
646
647
648
649
650
651
652
653
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
654
655
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
656
    fetchReorderGoals     = Flag False,
657
    fetchIndependentGoals = Flag False,
658
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
659
    fetchStrongFlags      = Flag False,
660
661
662
663
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
664
665
fetchCommand = CommandUI {
    commandName         = "fetch",
666
    commandSynopsis     = "Downloads packages for later installation.",
667
668
669
670
671
    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",
672
    commandNotes        = Nothing,
673
    commandDefaultFlags = defaultFetchFlags,
674
    commandOptions      = \ showOrParseArgs -> [
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
         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
696
697
698
699

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
700
701
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
702
703
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
704
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
705
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
706

Duncan Coutts's avatar
Duncan Coutts committed
707
708
  }

709
710
711
712
713
714
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
715
716
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
717
718
719
720
721
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
722
      freezeStrongFlags      :: Flag Bool,
723
724
725
726
727
728
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
729
730
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
731
732
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
733
    freezeReorderGoals     = Flag False,
734
735
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
736
    freezeStrongFlags      = Flag False,
737
738
739
740
741
742
743
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
744
745
746
747
748
749
750
751
    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",
752
    commandNotes        = Nothing,
753
    commandUsage        = usageFlags "freeze",
754
755
756
757
758
759
760
761
762
    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

763
764
765
766
767
768
769
770
771
772
       , 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 [] [])

773
774
775
776
777
778
779
780
       ] ++

       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
781
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
782
783
784

  }

785
786
787
788
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

789
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
790
791
updateCommand = CommandUI {
    commandName         = "update",
792
    commandSynopsis     = "Updates list of known packages.",
793
794
795
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
796
797
798
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
799
    commandUsage        = usageFlags "update",
800
    commandDefaultFlags = toFlag normal,
801
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
802
803
  }

804
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
805
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
806
    commandName         = "upgrade",
807
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
808
    commandDescription  = Nothing,
refold's avatar
refold committed
809
    commandUsage        = usageFlagsOrPackages "upgrade",
810
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
811
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
812
813
  }

Duncan Coutts's avatar
Duncan Coutts committed
814
815
816
817
818
819
820
821
822
823
824
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

825
826
827
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
828
    commandSynopsis     = "Check the package for common mistakes.",
829
830
831
832
833
834
    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",
835
    commandNotes        = Nothing,
836
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
837
    commandDefaultFlags = toFlag normal,
838
    commandOptions      = \_ -> []
839
840
  }

841
842
843
844
845
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
846
    commandNotes        = Nothing,
847
    commandUsage        = usageAlternatives "format" ["[FILE]"],
848
849
850
851
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

852
853
854
855
856
857
858
859
860
861
862
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      = \_ -> []
  }

863
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
864
865
runCommand = CommandUI {
    commandName         = "run",
866
    commandSynopsis     = "Builds and runs an executable.",
867
    commandDescription  = Just $ \pname -> wrapText $
868
869
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
870
871
872
873
      ++ "is built and executed.\n"
      ++ "\n"
      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "
      ++ "test-suite and get its full output.\n",
874
875
876
877
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " run\n"
       ++ "    Run the only executable in the current package;\n"
878
879
       ++ "  " ++ pname ++ " run foo -- --fooflag\n"
       ++ "    Works similar to `./foo --fooflag`.\n",
880
881
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
882
    commandDefaultFlags = mempty,
883
884
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
885
                          (commandOptions parent showOrParseArgs)
886
887
888
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
889
890
  }
  where
891
892
893
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

894
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
895

896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
-- ------------------------------------------------------------
-- * 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
914
915
916
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
917
918
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
919
         "You can store your Hackage login in the ~/.cabal/config file\n",
920
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
    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))
      ]
937
938
  }

939
940
941
942
943
944
945
946
947
948
949
950
951
instance Monoid ReportFlags where
  mempty = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = mempty
  }
  mappend a b = ReportFlags {
    reportUsername  = combine reportUsername,
    reportPassword  = combine reportPassword,
    reportVerbosity = combine reportVerbosity
  }
    where combine field = field a `mappend` field b

952
-- ------------------------------------------------------------
953
-- * Get flags
954
955
-- ------------------------------------------------------------

956
957
958
959
960
961
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
962

963
964
965
966
967
968
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
969
970
   }

971
972
973
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
974
975
    commandSynopsis     = "Download/Extract a package's source code (repository).",
    commandDescription  = Just $ \_ -> wrapText $
976
977
978
979
          "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",
980
981
982
983
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " get hlint\n"
       ++ "    Download the latest stable version of hlint;\n"
984
       ++ "  " ++ pname ++ " get lens --source-repository=head\n"
985
       ++ "    Download the source repository (i.e. git clone from github).\n",
986
    commandUsage        = usagePackages "get",
987
    commandDefaultFlags = defaultGetFlags,
988
    commandOptions      = \_ -> [
989
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
990
991

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

996
       ,option "s" ["source-repository"]
997
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
998
999
1000
         getSourceRepository (\v flags -> flags { getSourceRepository = v })
        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")
                                              (fmap (toFlag . Just) parse))