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

    , parsePackageArgs
41
42
43
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
44
45
    ) where

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

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

92
93
import Data.Char
         ( isSpace, isAlphaNum )
94
95
import Data.List
         ( intercalate )
96
import Data.Maybe
97
         ( listToMaybe, maybeToList, fromMaybe )
98
99
100
101
102
103
104
105
import Data.Monoid
         ( Monoid(..) )
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
106

107
108
109
110
111
112
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

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

126
127
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
128
129
130
131
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
132
    globalRemoteRepos       = mempty,
133
134
135
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
136
    globalWorldFile         = mempty,
137
138
    globalRequireSandbox    = Flag False,
    globalIgnoreSandbox     = Flag False
139
140
  }

141
142
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
143
    commandName         = "",
144
145
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
146
147
148
149
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
150
    commandDescription  = Just $ \pname ->
151
152
153
154
155
156
157
158
159
160
161
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
      in
         "Commands:\n"
      ++ unlines [ "  " ++ align name ++ "    " ++ description
                 | (name, description) <- cmdDescs ]
      ++ "\n"
      ++ "For more information about a command use:\n"
162
163
164
165
      ++ "  " ++ pname ++ " COMMAND --help\n"
      ++ "or\n"
      ++ "  " ++ pname ++ " help COMMAND\n"
      ++ "\n"
166
      ++ "To install Cabal packages from hackage use:\n"
167
168
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
169
170
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
171
    commandNotes = Nothing,
172
    commandDefaultFlags = mempty,
173
    commandOptions      = \showOrParseArgs ->
174
      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
      [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")

190
191
192
193
194
195
      ,option [] ["sandbox-config-file"]
         "Set an alternate location for the sandbox config file \
         \(default: './cabal.sandbox.config')"
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

196
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
197
         "requiring the presence of a sandbox for sandbox-aware commands"
198
199
200
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

201
202
203
204
205
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

206
207
208
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
209
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
210
211
212
213
214
215
216
217
218

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

221
222
223
224
225
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

226
227
228
229
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
230
231
232
233
234
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
235
236
237
238
239
240
241
242
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
243
    globalWorldFile         = mempty,
244
245
    globalRequireSandbox    = mempty,
    globalIgnoreSandbox     = mempty
246
247
  }
  mappend a b = GlobalFlags {
248
249
250
251
252
253
254
255
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
256
    globalWorldFile         = combine globalWorldFile,
257
258
    globalRequireSandbox    = combine globalRequireSandbox,
    globalIgnoreSandbox     = combine globalIgnoreSandbox
Duncan Coutts's avatar
Duncan Coutts committed
259
  }
260
261
262
263
264
265
266
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
267
      | remote <- fromNubList $ globalRemoteRepos globalFlags
268
269
270
271
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
272
      | local <- fromNubList $ globalLocalRepos globalFlags ]
273
274
275
276

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

278
configureCommand :: CommandUI ConfigFlags
279
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
280
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
281
282
  }

283
284
285
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

286
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
287
filterConfigureFlags flags cabalLibVersion
288
  | cabalLibVersion >= Version [1,19,2] [] = flags_latest
289
290
291
  | 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
292
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
293
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
294
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
295
  | otherwise = flags_latest
296
  where
297
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
298
299
    flags_latest = flags        { configConstraints = [] }

300
301
302
303
304
    -- Cabal < 1.19.2 doesn't know about '--exact-configuration'.
    flags_1_19_1 = flags_latest { configExactConfiguration = NoFlag }
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
305
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
306
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
307
308
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
309
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
310
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
311
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
312
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
313
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
314
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
315

316
317
318
319
320
321
322
323
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
324
    configExConstraints:: [UserConstraint],
325
    configPreferences  :: [Dependency],
326
327
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
328
329
330
  }

defaultConfigExFlags :: ConfigExFlags
331
332
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
333
334
335
336
337

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
338
         liftOptions fst setFst
339
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
340
                  . optionName) $ configureOptions  showOrParseArgs)
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
      ++ 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))
356
357
358
359
360
361
  , 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))
362
363
364
365

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
366
367
368
369
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
370
371

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
374
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
375
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
376
    (optArg allowNewerArgument
377
378
379
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

380
  ]
cheecheeo's avatar
cheecheeo committed
381
  where allowNewerArgument = "DEPS"
382
383
384
385

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
386
    configExConstraints= mempty,
387
    configPreferences  = mempty,
388
389
    configSolver       = mempty,
    configAllowNewer   = mempty
390
391
392
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
393
    configExConstraints= combine configExConstraints,
394
    configPreferences  = combine configPreferences,
395
396
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
397
398
399
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
400
401
402
403
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

404
405
406
407
408
409
410
411
412
413
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
414
  option [] ["only"]
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
  "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

-- ------------------------------------------------------------
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
-- * 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

464
465
466
467
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

468
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
469
testCommand = parent {
470
471
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
472
  commandOptions      =
473
    \showOrParseArgs -> liftOptions get1 set1
474
475
                        (commandOptions parent showOrParseArgs)
                        ++
476
477
478
479
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
480
481
  }
  where
482
483
484
    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)
485

486
487
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
488
489
490
491
492

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

493
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
494
benchmarkCommand = parent {
495
496
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
497
  commandOptions      =
498
    \showOrParseArgs -> liftOptions get1 set1
499
500
                        (commandOptions parent showOrParseArgs)
                        ++
501
502
503
504
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
505
  }
506
  where
507
508
509
    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)
510

511
512
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
513

514
-- ------------------------------------------------------------
515
-- * Fetch command
516
-- ------------------------------------------------------------
517

518
519
520
521
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
522
      fetchSolver           :: Flag PreSolver,
523
524
525
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
526
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
527
      fetchStrongFlags      :: Flag Bool,
528
529
530
531
532
533
534
535
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
536
537
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
538
    fetchReorderGoals     = Flag False,
539
    fetchIndependentGoals = Flag False,
540
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
541
    fetchStrongFlags      = Flag False,
542
543
544
545
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
546
547
fetchCommand = CommandUI {
    commandName         = "fetch",
548
    commandSynopsis     = "Downloads packages for later installation.",
549
550
551
552
553
    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",
554
    commandNotes        = Nothing,
555
    commandDefaultFlags = defaultFetchFlags,
556
    commandOptions      = \ showOrParseArgs -> [
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
         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
578
579
580
581

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
582
583
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
584
585
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
586
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
587
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
588

Duncan Coutts's avatar
Duncan Coutts committed
589
590
  }

591
592
593
594
595
596
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
597
598
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
599
600
601
602
603
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
604
      freezeStrongFlags      :: Flag Bool,
605
606
607
608
609
610
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
611
612
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
613
614
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
615
    freezeReorderGoals     = Flag False,
616
617
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
618
    freezeStrongFlags      = Flag False,
619
620
621
622
623
624
625
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
626
627
628
629
630
631
632
633
    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",
634
    commandNotes        = Nothing,
635
636
637
    commandUsage        = usageAlternatives "freeze" [""
                                                     ,"PACKAGES"
                                                     ],
638
639
640
641
642
643
644
645
646
    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

647
648
649
650
651
652
653
654
655
656
       , 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 [] [])

657
658
659
660
661
662
663
664
       ] ++

       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
665
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
666
667
668

  }

669
670
671
672
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

673
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
674
675
updateCommand = CommandUI {
    commandName         = "update",
676
    commandSynopsis     = "Updates list of known packages.",
677
678
679
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
680
681
682
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
683
    commandUsage        = usageFlags "update",
684
    commandDefaultFlags = toFlag normal,
685
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
686
687
  }

688
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
689
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
690
    commandName         = "upgrade",
691
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
692
    commandDescription  = Nothing,
refold's avatar
refold committed
693
    commandUsage        = usageFlagsOrPackages "upgrade",
694
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
695
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
696
697
  }

Duncan Coutts's avatar
Duncan Coutts committed
698
699
700
701
702
703
704
705
706
707
708
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

709
710
711
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
712
    commandSynopsis     = "Check the package for common mistakes.",
713
714
715
716
717
718
    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",
719
    commandNotes        = Nothing,
720
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
721
    commandDefaultFlags = toFlag normal,
722
    commandOptions      = \_ -> []
723
724
  }

725
726
727
728
729
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
730
    commandNotes        = Nothing,
731
    commandUsage        = usageAlternatives "format" ["[FILE]"],
732
733
734
735
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

736
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
737
738
runCommand = CommandUI {
    commandName         = "run",
739
740
741
742
743
    commandSynopsis     = "Builds and runs an executable.",
    commandDescription  = Just $ \_ -> wrapText $
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
      ++ "is built and executed.\n",
744
    commandNotes        = Nothing,
745
746
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
747
    commandDefaultFlags = mempty,
748
749
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
750
                          (commandOptions parent showOrParseArgs)
751
752
753
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
754
755
  }
  where
756
757
758
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

759
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
760

761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
-- ------------------------------------------------------------
-- * 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
779
780
781
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
782
783
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
784
         "You can store your Hackage login in the ~/.cabal/config file\n",
785
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
    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))
      ]
802
803
  }

804
805
806
807
808
809
810
811
812
813
814
815
816
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

817
-- ------------------------------------------------------------
818
-- * Get flags
819
820
-- ------------------------------------------------------------

821
822
823
824
825
826
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
827

828
829
830
831
832
833
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
834
835
   }

836
837
838
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
839
840
    commandSynopsis     = "Download/Extract a package's source code (repository).",
    commandDescription  = Just $ \_ -> wrapText $
841
842
843
844
          "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",
845
    commandNotes        = Nothing,
846
    commandUsage        = usagePackages "get",
847
    commandDefaultFlags = defaultGetFlags,
848
    commandOptions      = \_ -> [
849
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
850
851

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

856
       ,option "s" ["source-repository"]
857
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
858
859
860
861
862
863
         getSourceRepository (\v flags -> flags { getSourceRepository = v })
        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")
                                              (fmap (toFlag . Just) parse))
                                  (Flag Nothing)
                                  (map (fmap show) . flagToList))

864
865
866
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
867
           getPristine (\v flags -> flags { getPristine = v })
868
           trueArg
869
870
871
       ]
  }

872
873
874
875
876
877
878
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
unpackCommand = getCommand {
  commandName  = "unpack",
  commandUsage = usagePackages "unpack"
  }

879
instance Monoid GetFlags where
880
881
882
883
884
885
  mempty = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = mempty
    }
886
887
888
889
890
  mappend a b = GetFlags {
    getDestDir          = combine getDestDir,
    getPristine         = combine getPristine,
    getSourceRepository = combine getSourceRepository,
    getVerbosity        = combine getVerbosity
891
892
893
  }
    where combine field = field a `mappend` field b

894
895
896
897
898
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
899
    listInstalled    :: Flag Bool,
900
    listSimpleOutput :: Flag Bool,
901
902
    listVerbosity    :: Flag Verbosity,
    listPackageDBs   :: [Maybe PackageDB]
903
904
905
906
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
907
    listInstalled    = Flag False,
908
    listSimpleOutput = Flag False,
909
910
    listVerbosity    = toFlag normal,
    listPackageDBs   = []
911
912
913
914
915
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
916
    commandSynopsis     = "List packages matching a search string.",
917
918
919
920
921
922
923
924
    commandDescription  = Just $ \_ -> wrapText $
         "List all packages, or all packages matching one of the search"
      ++ " strings.\n"
      ++ "\n"
      ++ "If there is a sandbox in the current directory and "
      ++ "config:ignore-sandbox is False, use the sandbox package database. "
      ++ "Otherwise, use the package database specified with --package-db. "
      ++ "If not specified, use the user package database.\n",
925
    commandNotes        = Nothing,
926
927
    commandUsage        = usageAlternatives "list" [ "[FLAGS]"
                                                   , "[FLAGS] STRINGS"],
928
    commandDefaultFlags = defaultListFlags,
929
    commandOptions      = \_ -> [
930
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
931

932
        , option [] ["installed"]
933
934
935
936
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

937
938
939
940
941
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

942
943
944
945
946
        , option "" ["package-db"]
          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
          listPackageDBs (\v flags -> flags { listPackageDBs = v })
          (reqArg' "DB" readPackageDbList showPackageDbList)

947
948
949
950
        ]
  }

instance Monoid ListFlags where
951
952
953
954
955
956
  mempty = ListFlags {
    listInstalled    = mempty,
    listSimpleOutput = mempty,
    listVerbosity    = mempty,
    listPackageDBs   = mempty
    }
957
  mappend a b = ListFlags {
958
    listInstalled    = combine listInstalled,
959
    listSimpleOutput = combine listSimpleOutput,
960
961
    listVerbosity    = combine listVerbosity,
    listPackageDBs   = combine listPackageDBs
962
963
964
  }
    where combine field = field a `mappend` field b

965
966
967
968
969
-- ------------------------------------------------------------
-- * Info flags
-- ------------------------------------------------------------

data InfoFlags = InfoFlags {
970
971
    infoVerbosity  :: Flag Verbosity,
    infoPackageDBs :: [Maybe PackageDB]
972
973
974
975
  }

defaultInfoFlags :: InfoFlags
defaultInfoFlags = InfoFlags {
976
977
    infoVerbosity  = toFlag normal,
    infoPackageDBs = []
978
979
980
981
982
983
  }

infoCommand  :: CommandUI InfoFlags
infoCommand = CommandUI {
    commandName         = "info",
    commandSynopsis     = "Display detailed information about a particular package.",
984
985
986
987
988
    commandDescription  = Just $ \_ -> wrapText $
         "If there is a sandbox in the current directory and "
      ++ "config:ignore-sandbox is False, use the sandbox package database. "
      ++ "Otherwise, use the package database specified with --package-db. "
      ++ "If not specified, use the user package database.\n",
989
    commandNotes        = Nothing,
990
    commandUsage        = usageAlternatives "info" ["[FLAGS] PACKAGES"],
991
992
993
    commandDefaultFlags = defaultInfoFlags,
    commandOptions      = \_ -> [
        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })
994
995
996
997
998
999

        , option "" ["package-db"]
          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
          infoPackageDBs (\v flags -> flags { infoPackageDBs = v })
          (reqArg' "DB" readPackageDbList showPackageDbList)

1000
        ]