Setup.hs 90.6 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(..), ConstraintSource(..) )
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,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
123
    globalConstraintsFile   :: Flag FilePath,
124
    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
125
    globalCacheDir          :: Flag FilePath,
126
    globalLocalRepos        :: NubList FilePath,
127
    globalLogsDir           :: Flag FilePath,
128
    globalWorldFile         :: Flag FilePath,
129
    globalRequireSandbox    :: Flag Bool,
130
131
    globalIgnoreSandbox     :: Flag Bool,
    globalHttpTransport     :: Flag String
132
  }
Duncan Coutts's avatar
Duncan Coutts committed
133

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

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

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

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
288
289
290
291
292
      ,option [] ["constraints-file"]
         "Set a location for a global constraints file for projects without their own cabal.config freeze file."
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

293
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
294
         "requiring the presence of a sandbox for sandbox-aware commands"
295
296
297
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

298
299
300
301
302
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

303
      ,option [] ["http-transport"]
304
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
305
306
307
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")

308
309
310
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
311
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
312
313
314
315
316
317
318
319
320

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

323
324
325
326
327
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

328
329
330
331
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
332
333
334
335
336
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
337
338
339
340
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
341
    globalConstraintsFile   = mempty,
342
343
344
345
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
346
    globalWorldFile         = mempty,
347
    globalRequireSandbox    = mempty,
348
349
    globalIgnoreSandbox     = mempty,
    globalHttpTransport     = mempty
350
351
  }
  mappend a b = GlobalFlags {
352
353
354
355
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
356
    globalConstraintsFile   = combine globalConstraintsFile,
357
358
359
360
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
361
    globalWorldFile         = combine globalWorldFile,
362
    globalRequireSandbox    = combine globalRequireSandbox,
363
364
    globalIgnoreSandbox     = combine globalIgnoreSandbox,
    globalHttpTransport     = combine globalHttpTransport
Duncan Coutts's avatar
Duncan Coutts committed
365
  }
366
367
368
369
370
371
372
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
373
      | remote <- fromNubList $ globalRemoteRepos globalFlags
374
375
376
377
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
378
      | local <- fromNubList $ globalLocalRepos globalFlags ]
379
380
381
382

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

384
configureCommand :: CommandUI ConfigFlags
385
386
configureCommand = c
  { commandDefaultFlags = mempty
387
388
389
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
390
391
392
393
394
395
       ++ "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
396
  }
397
398
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
399

400
401
402
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

403
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
404
filterConfigureFlags flags cabalLibVersion
405
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
406
  -- ^ NB: we expect the latest version to be the most common case.
407
408
409
  | 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
410
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
411
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
412
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
413
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
414
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
415
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
416
  | otherwise = flags_latest
417
  where
418
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
419
420
    flags_latest = flags        { configConstraints = [] }

421
422
423
424
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
                                , configProfLibDetail = NoFlag }

425
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
426
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
427

428
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
429
430
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
431
      flags_1_21_0 { configRelocatable = NoFlag
432
433
434
435
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
436
437
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
438
                   }
439
440
441
442
    -- 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 }
443
444
445
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
446
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
447
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
448
449
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
450
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
451
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
452
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
453
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
454
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
455
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
456

457
458
459
460
461
462
463
464
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
465
    configExConstraints:: [(UserConstraint, ConstraintSource)],
466
    configPreferences  :: [Dependency],
467
468
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
469
470
471
  }

defaultConfigExFlags :: ConfigExFlags
472
473
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
474
475
476
477
478

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
479
         liftOptions fst setFst
480
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
481
                  . optionName) $ configureOptions  showOrParseArgs)
482
483
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
484
485
486
487
488
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

489
490
491
492
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
493
494
495
496
497
498
499
  [ 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))
500
501
502
503
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
504
505
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
506
507
508
509

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
510
511
512
513
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
514
515

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
518
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
519
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
520
    (optArg allowNewerArgument
521
522
523
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

524
  ]
cheecheeo's avatar
cheecheeo committed
525
  where allowNewerArgument = "DEPS"
526
527
528
529

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
530
    configExConstraints= mempty,
531
    configPreferences  = mempty,
532
533
    configSolver       = mempty,
    configAllowNewer   = mempty
534
535
536
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
537
    configExConstraints= combine configExConstraints,
538
    configPreferences  = combine configPreferences,
539
540
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
541
542
543
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
544
545
546
547
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

548
549
550
551
552
553
554
555
556
557
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
558
  option [] ["only"]
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
  "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

-- ------------------------------------------------------------
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
-- * 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

608
609
610
611
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

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

630
631
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
632
633
634
635
636

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

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

655
656
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
657

658
-- ------------------------------------------------------------
659
-- * Fetch command
660
-- ------------------------------------------------------------
661

662
663
664
665
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
666
      fetchSolver           :: Flag PreSolver,
667
668
669
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
670
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
671
      fetchStrongFlags      :: Flag Bool,
672
673
674
675
676
677
678
679
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
680
681
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
682
    fetchReorderGoals     = Flag False,
683
    fetchIndependentGoals = Flag False,
684
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
685
    fetchStrongFlags      = Flag False,
686
687
688
689
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
690
691
fetchCommand = CommandUI {
    commandName         = "fetch",
692
    commandSynopsis     = "Downloads packages for later installation.",
693
694
695
696
697
    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",
698
    commandNotes        = Nothing,
699
    commandDefaultFlags = defaultFetchFlags,
700
    commandOptions      = \ showOrParseArgs -> [
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
         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
722
723
724
725

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
726
727
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
728
729
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
730
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
731
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
732

Duncan Coutts's avatar
Duncan Coutts committed
733
734
  }

735
736
737
738
739
740
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
741
742
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
743
744
745
746
747
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
748
      freezeStrongFlags      :: Flag Bool,
749
750
751
752
753
754
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
755
756
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
757
758
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
759
    freezeReorderGoals     = Flag False,
760
761
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
762
    freezeStrongFlags      = Flag False,
763
764
765
766
767
768
769
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
770
771
772
773
774
775
776
777
    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",
778
    commandNotes        = Nothing,
779
    commandUsage        = usageFlags "freeze",
780
781
782
783
784
785
786
787
788
    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

789
790
791
792
793
794
795
796
797
798
       , 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 [] [])

799
800
801
802
803
804
805
806
       ] ++

       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
807
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
808
809
810

  }

811
812
813
814
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

815
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
816
817
updateCommand = CommandUI {
    commandName         = "update",
818
    commandSynopsis     = "Updates list of known packages.",
819
820
821
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
822
823
824
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
825
    commandUsage        = usageFlags "update",
826
    commandDefaultFlags = toFlag normal,
827
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
828
829
  }

830
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
831
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
832
    commandName         = "upgrade",
833
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
834
    commandDescription  = Nothing,
refold's avatar
refold committed
835
    commandUsage        = usageFlagsOrPackages "upgrade",
836
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
837
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
838
839
  }

Duncan Coutts's avatar
Duncan Coutts committed
840
841
842
843
844
845
846
847
848
849
850
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

851
852
853
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
854
    commandSynopsis     = "Check the package for common mistakes.",
855
856
857
858
859
860
    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",
861
    commandNotes        = Nothing,
862
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
863
    commandDefaultFlags = toFlag normal,
864
    commandOptions      = \_ -> []
865
866
  }

867
868
869
870
871
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
872
    commandNotes        = Nothing,
873
    commandUsage        = usageAlternatives "format" ["[FILE]"],
874
875
876
877
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

878
879
880
881
882
883
884
885
886
887
888
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      = \_ -> []
  }

889
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
890
891
runCommand = CommandUI {
    commandName         = "run",
892
    commandSynopsis     = "Builds and runs an executable.",
893
    commandDescription  = Just $ \pname -> wrapText $
894
895
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
896
897
898
899
      ++ "is built and executed.\n"
      ++ "\n"
      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "
      ++ "test-suite and get its full output.\n",
900
901
902
903
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " run\n"
       ++ "    Run the only executable in the current package;\n"
904
905
       ++ "  " ++ pname ++ " run foo -- --fooflag\n"
       ++ "    Works similar to `./foo --fooflag`.\n",
906
907
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
908
    commandDefaultFlags = mempty,
909
910
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
911
                          (commandOptions parent showOrParseArgs)
912
913
914
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
915
916
  }
  where
917
918
919
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

920
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
921

922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
-- ------------------------------------------------------------
-- * 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
940
941
942
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
943
944
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
945
         "You can store your Hackage login in the ~/.cabal/config file\n",
946
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
    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))
      ]
963
964
  }

965
966
967
968
969
970
971
972
973
974
975
976
977
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

978
-- ------------------------------------------------------------
979
-- * Get flags
980
981
-- ------------------------------------------------------------

982
983
984
985
986
987
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
988

989
990
991
992
993
994
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
995
996
   }

997
998
999
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
1000
    commandSynopsis     = "Download/Extract a package's source code (repository).",