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

    , parsePackageArgs
50
51
52
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
53
    , readRepo
54
55
    ) where

56
import Distribution.Client.Types
Edsko de Vries's avatar
Edsko de Vries committed
57
         ( Username(..), Password(..), RemoteRepo(..) )
58
59
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
60
import Distribution.Client.Dependency.Types
61
         ( PreSolver(..), ConstraintSource(..) )
62
63
import qualified Distribution.Client.Init.Types as IT
         ( InitFlags(..), PackageType(..) )
64
65
import Distribution.Client.Targets
         ( UserConstraint, readUserConstraint )
66
67
import Distribution.Utils.NubList
         ( NubList, toNubList, fromNubList)
68

69

70
import Distribution.Simple.Compiler (PackageDB)
71
72
import Distribution.Simple.Program
         ( defaultProgramConfiguration )
73
74
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
Duncan Coutts's avatar
Duncan Coutts committed
75
import qualified Distribution.Simple.Setup as Cabal
76
import Distribution.Simple.Setup
77
78
         ( ConfigFlags(..), BuildFlags(..), ReplFlags
         , TestFlags(..), BenchmarkFlags(..)
79
         , SDistFlags(..), HaddockFlags(..)
80
         , readPackageDbList, showPackageDbList
Edsko de Vries's avatar
Edsko de Vries committed
81
         , Flag(..), toFlag, flagToMaybe, flagToList
82
83
         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg
         , readPToMaybe, optionNumJobs )
84
import Distribution.Simple.InstallDirs
85
86
         ( PathTemplate, InstallDirs(sysconfdir)
         , toPathTemplate, fromPathTemplate )
87
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
88
         ( Version(Version), anyVersion, thisVersion )
89
import Distribution.Package
90
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
91
import Distribution.PackageDescription
92
         ( BuildType(..), RepoKind(..) )
93
import Distribution.Text
94
         ( Text(..), display )
95
import Distribution.ReadE
96
         ( ReadE(..), readP_to_E, succeedReadE )
97
import qualified Distribution.Compat.ReadP as Parse
98
         ( ReadP, char, munch1, pfail,  (+++) )
99
100
import Distribution.Compat.Semigroup
         ( Semigroup((<>)) )
101
102
import Distribution.Verbosity
         ( Verbosity, normal )
103
import Distribution.Simple.Utils
104
         ( wrapText, wrapLine )
105
import Distribution.Client.GlobalFlags
Edsko de Vries's avatar
Edsko de Vries committed
106
107
108
         ( GlobalFlags(..), defaultGlobalFlags
         , RepoContext(..), withRepoContext
         )
109

110
import Data.Char
111
         ( isAlphaNum )
112
import Data.List
113
         ( intercalate, deleteFirstsBy )
114
import Data.Maybe
115
         ( maybeToList, fromMaybe )
116
#if !MIN_VERSION_base(4,8,0)
117
118
import Data.Monoid
         ( Monoid(..) )
119
#endif
120
121
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
122
123
124
125
126
127
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
128

129
130
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
131
    commandName         = "",
132
133
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
134
135
136
137
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
138
    commandDescription  = Just $ \pname ->
139
140
141
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
        -- 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"
          ]
177
178
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
179
180
181
182
183
184
185
186
187
        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
188
189
      in
         "Commands:\n"
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
      ++ 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"
226
        , addCmd "sandbox"
227
228
229
230
231
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
232
233
      ++ "\n"
      ++ "For more information about a command use:\n"
234
235
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
236
      ++ "\n"
237
      ++ "To install Cabal packages from hackage use:\n"
238
239
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
240
241
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
242
    commandNotes = Nothing,
243
    commandDefaultFlags = mempty,
244
245
246
247
248
249
250
251
252
253
254
    commandOptions = args
  }
  where
    args :: ShowOrParseArgs -> [OptionField GlobalFlags]
    args ShowArgs  = argsShown
    args ParseArgs = argsShown ++ argsNotShown

    -- arguments we want to show in the help
    argsShown :: [OptionField GlobalFlags]
    argsShown = [
       option ['V'] ["version"]
255
256
257
258
259
260
261
262
263
264
265
266
267
268
         "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")

269
      ,option [] ["sandbox-config-file"]
270
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
271
272
273
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
274
275
      ,option [] ["default-user-config"]
         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
276
277
278
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

279
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
280
         "requiring the presence of a sandbox for sandbox-aware commands"
281
282
283
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

284
285
286
287
288
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

289
      ,option [] ["ignore-expiry"]
Edsko de Vries's avatar
Edsko de Vries committed
290
         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
291
292
293
         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
         trueArg

294
      ,option [] ["http-transport"]
295
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
296
297
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")
298
      ]
299

300
301
302
303
    -- arguments we don't want shown in the help
    argsNotShown :: [OptionField GlobalFlags]
    argsNotShown = [
       option [] ["remote-repo"]
304
305
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
306
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
307
308
309
310
311
312
313
314
315

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

318
319
320
321
322
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

323
324
325
326
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
327
328
329
330
331
      ]

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

333
configureCommand :: CommandUI ConfigFlags
334
335
configureCommand = c
  { commandDefaultFlags = mempty
336
337
338
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
339
340
341
342
343
344
       ++ "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
345
  }
346
347
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
348

349
350
351
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

352
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
353
filterConfigureFlags flags cabalLibVersion
354
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
355
  -- ^ NB: we expect the latest version to be the most common case.
356
357
  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10
  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0
358
  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0
359
  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0
360
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
361
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
362
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
363
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
364
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
365
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
366
  | otherwise = flags_latest
367
  where
368
369
370
371
372
    flags_latest = flags        {
      -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
      configConstraints = [],
      -- Passing '--allow-newer' to Setup.hs is unnecessary, we use
      -- '--exact-configuration' instead.
373
      configAllowNewer  = Just Cabal.AllowNewerNone
374
      }
375

376
377
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
378
379
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
380

381
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
382
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
383

384
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
385
386
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
387
      flags_1_21_0 { configRelocatable = NoFlag
388
389
390
391
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
392
393
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
394
                   }
395
396
397
398
    -- 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 }
399
400
401
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
402
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
403
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
404
405
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
406
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
407
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
408
409
410
411
    -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'
    -- and '--enable/disable-library-coverage'.
    flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag
                                , configDynExe      = NoFlag }
412
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
413
    flags_1_10_0 = flags_1_12_0 { configTests       = NoFlag }
414
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
415
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
416

417
418
419
420
421
422
423
424
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
425
    configExConstraints:: [(UserConstraint, ConstraintSource)],
426
    configPreferences  :: [Dependency],
427
    configSolver       :: Flag PreSolver
428
  }
429
  deriving (Eq, Generic)
430
431

defaultConfigExFlags :: ConfigExFlags
432
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }
433
434
435
436
437

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
438
         liftOptions fst setFst
439
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
440
                  . optionName) $ configureOptions  showOrParseArgs)
441
442
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
443
444
445
446
447
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

448
449
450
451
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
452
453
454
455
456
457
458
  [ 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))
459
460
461
462
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
463
464
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
465
466
467
468

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
469
470
471
472
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
473
474

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

476
477
478
479
480
  ]

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
481
    configExConstraints= mempty,
482
    configPreferences  = mempty,
483
    configSolver       = mempty
484
  }
485
486
487
488
  mappend = (<>)

instance Semigroup ConfigExFlags where
  a <> b = ConfigExFlags {
489
    configCabalVersion = combine configCabalVersion,
490
    configExConstraints= combine configExConstraints,
491
    configPreferences  = combine configPreferences,
492
    configSolver       = combine configSolver
493
494
495
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
496
497
498
499
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

500
501
502
503
504
505
506
507
508
509
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
510
  option [] ["only"]
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
  "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
  }
536
537
538
539
  mappend = (<>)

instance Semigroup BuildExFlags where
  a <> b = BuildExFlags {
540
541
542
543
544
    buildOnly    = combine buildOnly
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
-- * 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

563
564
565
566
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

567
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
568
testCommand = parent {
569
570
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
571
  commandOptions      =
572
    \showOrParseArgs -> liftOptions get1 set1
573
574
                        (commandOptions parent showOrParseArgs)
                        ++
575
576
577
578
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
579
580
  }
  where
581
582
583
    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)
584

585
586
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
587
588
589
590
591

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

592
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
593
benchmarkCommand = parent {
594
595
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
596
  commandOptions      =
597
    \showOrParseArgs -> liftOptions get1 set1
598
599
                        (commandOptions parent showOrParseArgs)
                        ++
600
601
602
603
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
604
  }
605
  where
606
607
608
    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)
609

610
611
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
612

613
-- ------------------------------------------------------------
614
-- * Fetch command
615
-- ------------------------------------------------------------
616

617
618
619
620
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
621
      fetchSolver           :: Flag PreSolver,
622
623
624
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
625
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
626
      fetchStrongFlags      :: Flag Bool,
627
628
629
630
631
632
633
634
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
635
636
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
637
    fetchReorderGoals     = Flag False,
638
    fetchIndependentGoals = Flag False,
639
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
640
    fetchStrongFlags      = Flag False,
641
642
643
644
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
645
646
fetchCommand = CommandUI {
    commandName         = "fetch",
647
    commandSynopsis     = "Downloads packages for later installation.",
648
649
650
651
652
    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",
653
    commandNotes        = Nothing,
654
    commandDefaultFlags = defaultFetchFlags,
655
    commandOptions      = \ showOrParseArgs -> [
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
         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
677
678
679
680

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
681
682
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
683
684
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
685
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
686
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
687

Duncan Coutts's avatar
Duncan Coutts committed
688
689
  }

690
691
692
693
694
695
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
696
697
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
698
699
700
701
702
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
703
      freezeStrongFlags      :: Flag Bool,
704
705
706
707
708
709
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
710
711
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
712
713
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
714
    freezeReorderGoals     = Flag False,
715
716
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
717
    freezeStrongFlags      = Flag False,
718
719
720
721
722
723
724
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
725
726
727
728
729
730
731
732
    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",
733
    commandNotes        = Nothing,
734
    commandUsage        = usageFlags "freeze",
735
736
737
738
739
740
741
742
743
    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

744
745
746
747
748
749
750
751
752
753
       , 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 [] [])

754
755
756
757
758
759
760
761
       ] ++

       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
762
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
763
764
765

  }

766
767
768
769
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

770
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
771
772
updateCommand = CommandUI {
    commandName         = "update",
773
    commandSynopsis     = "Updates list of known packages.",
774
775
776
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
777
778
779
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
780
    commandUsage        = usageFlags "update",
781
    commandDefaultFlags = toFlag normal,
782
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
783
784
  }

785
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
786
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
787
    commandName         = "upgrade",
788
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
789
    commandDescription  = Nothing,
refold's avatar
refold committed
790
    commandUsage        = usageFlagsOrPackages "upgrade",
791
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
792
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
793
794
  }

Duncan Coutts's avatar
Duncan Coutts committed
795
796
797
798
799
800
801
802
803
804
805
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

806
807
808
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
809
    commandSynopsis     = "Check the package for common mistakes.",
810
811
812
813
814
815
    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",
816
    commandNotes        = Nothing,
817
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
818
    commandDefaultFlags = toFlag normal,
819
    commandOptions      = \_ -> []
820
821
  }

822
823
824
825
826
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
827
    commandNotes        = Nothing,
828
    commandUsage        = usageAlternatives "format" ["[FILE]"],
829
830
831
832
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

833
834
835
836
837
838
839
840
841
842
843
uninstallCommand  :: CommandUI (Flag Verbosity)
uninstallCommand = CommandUI {
    commandName         = "uninstall",
    commandSynopsis     = "Warn about 'uninstall' not being implemented.",
    commandDescription  = Nothing,
    commandNotes        = Nothing,
    commandUsage        = usageAlternatives "uninstall" ["PACKAGES"],
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

Maciek Makowski's avatar
Maciek Makowski committed
844
845
846
847
848
849
850
851
852
853
854
855
manpageCommand :: CommandUI (Flag Verbosity)
manpageCommand = CommandUI {
    commandName         = "manpage",
    commandSynopsis     = "Outputs manpage source.",
    commandDescription  = Just $ \_ ->
      "Output manpage source to STDOUT.\n",
    commandNotes        = Nothing,
    commandUsage        = usageFlags "manpage",
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> [optionVerbosity id const]
  }

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

887
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
888

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

932
933
934
935
936
937
instance Monoid ReportFlags where
  mempty = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = mempty
  }
938
939
940
941
  mappend = (<>)

instance Semigroup ReportFlags where
  a <> b = ReportFlags {
942
943
944
945
946
947
    reportUsername  = combine reportUsername,
    reportPassword  = combine reportPassword,
    reportVerbosity = combine reportVerbosity
  }
    where combine field = field a `mappend` field b

948
-- ------------------------------------------------------------
949
-- * Get flags
950
951
-- ------------------------------------------------------------

952
953
954
955
956
957
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
958

959
960
961
962
963
964
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
965
966
   }

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

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

992
       ,option "s" ["source-repository"]
993
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
994
995
996
997
998
999
         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))

1000
1001
1002
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
1003
           getPristine (\v flags -> flags { getPristine = v })
1004
           trueArg
1005
1006
1007
       ]
  }

1008
1009
1010
1011
1012
1013
1014
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
unpackCommand = getCommand {
  commandName  = "unpack",
  commandUsage = usagePackages "unpack"
  }

1015
instance Monoid GetFlags where
1016
1017
1018
1019
1020
1021
  mempty = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = mempty
    }
1022
1023
1024
1025
  mappend = (<>)

instance Semigroup GetFlags where
  a <> b = GetFlags {
1026
1027
1028
1029
    getDestDir          = combine getDestDir,
    getPristine         = combine getPristine,
    getSourceRepository = combine getSourceRepository,
    getVerbosity        = combine getVerbosity
1030
1031
1032
  }
    where combine field = field a `mappend` field b

1033
1034
1035
1036
1037
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
1038
    listInstalled    :: Flag Bool,
1039
    listSimpleOutput :: Flag Bool,
1040
1041
    listVerbosity    :: Flag Verbosity,
    listPackageDBs   :: [Maybe PackageDB]
1042
1043
1044
1045
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
1046
    listInstalled    = Flag False,
1047
    listSimpleOutput = Flag False,
1048
1049
    listVerbosity    = toFlag normal,
    listPackageDBs   = []
1050
1051
1052
1053
1054
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
1055
    commandSynopsis     = "List packages matching a search string.",
1056
1057
1058
1059
1060
1061
1062
1063
    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. "