Setup.hs 58.1 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(..), globalRepos
15
    , configureCommand, ConfigFlags(..), filterConfigureFlags
16
17
    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
                        , configureExOptions
18
19
    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
    , 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
    , getCommand, unpackCommand, GetFlags(..)
27
    , checkCommand
28
    , uploadCommand, UploadFlags(..)
29
    , reportCommand, ReportFlags(..)
refold's avatar
refold committed
30
    , runCommand
31
    , initCommand, IT.InitFlags(..)
32
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
33
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
refold's avatar
refold committed
34
    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
35
36

    , parsePackageArgs
37
38
39
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
40
41
    ) where

42
import Distribution.Client.Types
43
         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )
44
45
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
46
import Distribution.Client.Dependency.Types
47
         ( PreSolver(..) )
48
49
import qualified Distribution.Client.Init.Types as IT
         ( InitFlags(..), PackageType(..) )
50
51
import Distribution.Client.Targets
         ( UserConstraint, readUserConstraint )
52
53
54

import Distribution.Simple.Program
         ( defaultProgramConfiguration )
55
import Distribution.Simple.Command hiding (boolOpt)
Duncan Coutts's avatar
Duncan Coutts committed
56
import qualified Distribution.Simple.Setup as Cabal
57
import Distribution.Simple.Setup
58
59
60
         ( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)
         , SDistFlags(..), HaddockFlags(..)
         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
61
         , optionVerbosity, boolOpt, trueArg, falseArg )
62
63
import Distribution.Simple.InstallDirs
         ( PathTemplate, toPathTemplate, fromPathTemplate )
64
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
65
         ( Version(Version), anyVersion, thisVersion )
66
import Distribution.Package
67
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
68
69
import Distribution.PackageDescription
         ( RepoKind(..) )
70
import Distribution.Text
71
         ( Text(..), display )
72
import Distribution.ReadE
73
         ( ReadE(..), readP_to_E, succeedReadE )
74
import qualified Distribution.Compat.ReadP as Parse
Andres Löh's avatar
Andres Löh committed
75
         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, (+++) )
76
77
import Distribution.Verbosity
         ( Verbosity, normal )
78
79
import Distribution.Simple.Utils
         ( wrapText )
80

81
82
import Data.Char
         ( isSpace, isAlphaNum )
83
84
import Data.List
         ( intercalate )
85
import Data.Maybe
86
         ( listToMaybe, maybeToList, fromMaybe )
87
88
89
90
91
92
93
94
import Data.Monoid
         ( Monoid(..) )
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
95

96
97
98
99
100
101
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
102
103
104
105
106
107
108
109
110
    globalVersion           :: Flag Bool,
    globalNumericVersion    :: Flag Bool,
    globalConfigFile        :: Flag FilePath,
    globalSandboxConfigFile :: Flag FilePath,
    globalRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.
    globalCacheDir          :: Flag FilePath,
    globalLocalRepos        :: [FilePath],
    globalLogsDir           :: Flag FilePath,
    globalWorldFile         :: Flag FilePath
111
  }
Duncan Coutts's avatar
Duncan Coutts committed
112

113
114
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
115
116
117
118
119
120
121
122
123
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
    globalRemoteRepos       = [],
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
    globalWorldFile         = mempty
124
125
126
127
128
129
  }

globalCommand :: CommandUI GlobalFlags
globalCommand = CommandUI {
    commandName         = "",
    commandSynopsis     = "",
130
131
132
133
    commandUsage        = \_ ->
         "This program is the command line interface "
           ++ "to the Haskell Cabal infrastructure.\n"
      ++ "See http://www.haskell.org/cabal/ for more information.\n",
134
    commandDescription  = Just $ \pname ->
135
136
137
138
139
140
         "For more information about a command use:\n"
      ++ "  " ++ pname ++ " COMMAND --help\n\n"
      ++ "To install Cabal packages from hackage use:\n"
      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
141
142
    commandDefaultFlags = defaultGlobalFlags,
    commandOptions      = \showOrParseArgs ->
143
      (case showOrParseArgs of ShowArgs -> take 4; ParseArgs -> id)
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
      [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")

159
160
161
162
163
164
      ,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")

165
166
167
168
169
170
171
172
173
174
175
176
177
178
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
         (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo))

      ,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 })
         (reqArg' "DIR" (\x -> [x]) id)
179

180
181
182
183
184
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

185
186
187
188
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
189
190
191
192
193
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
194
195
196
197
198
199
200
201
202
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
    globalWorldFile         = mempty
203
204
  }
  mappend a b = GlobalFlags {
205
206
207
208
209
210
211
212
213
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
    globalWorldFile         = combine globalWorldFile
Duncan Coutts's avatar
Duncan Coutts committed
214
  }
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
      | remote <- globalRemoteRepos globalFlags
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
      | local <- globalLocalRepos globalFlags ]

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

233
configureCommand :: CommandUI ConfigFlags
234
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
235
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
236
237
  }

238
239
240
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

241
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
242
filterConfigureFlags flags cabalLibVersion
243
  | cabalLibVersion >= Version [1,17,0] [] = flags
244
245
246
  | 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
247
  | cabalLibVersion <  Version [1,17,0] [] = flags_1_17_0
248
249
250
251

  -- A no-op that silences the "pattern match is non-exhaustive" warning.
  | otherwise = flags
  where
252
253
    -- Cabal < 1.17.0 doesn't know about --extra-prog-path.
    flags_1_17_0 = flags        { configProgramPathExtra = [] }
254
    -- Cabal < 1.14.0 doesn't know about --disable-benchmarks.
255
    flags_1_14_0 = flags_1_17_0 { configBenchmarks  = NoFlag }
256
257
258
259
    -- Cabal < 1.10.0 doesn't know about --disable-tests.
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
    -- Cabal < 1.3.10 does not grok the constraints flag.
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
260

261
262
263
264
265
266
267
268
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
269
    configExConstraints:: [UserConstraint],
270
    configPreferences  :: [Dependency],
271
    configSolver       :: Flag PreSolver
272
273
274
  }

defaultConfigExFlags :: ConfigExFlags
275
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }
276
277
278
279
280

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
281
282
         liftOptions fst setFst (filter ((/="constraint") . optionName) $
                                 configureOptions   showOrParseArgs)
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
      ++ 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))
298
299
300
301
302
303
  , 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))
304
305
306
307

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
308
309
310
311
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
312
313

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
314
315
316
317
318
  ]

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
319
    configExConstraints= mempty,
320
321
    configPreferences  = mempty,
    configSolver       = mempty
322
323
324
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
325
    configExConstraints= combine configExConstraints,
326
327
    configPreferences  = combine configPreferences,
    configSolver       = combine configSolver
328
329
330
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
331
332
333
334
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildNumJobs  :: Flag (Maybe Int),
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
  option "j" ["jobs"]
  "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)"
  buildNumJobs (\v flags -> flags { buildNumJobs = v })
  (optArg "NUM" (fmap Flag numJobsParser)
   (Flag Nothing)
   (map (Just . maybe "$ncpus" show) . flagToList))

  : option [] ["only"]
  "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 {
    buildNumJobs = mempty,
    buildOnly    = mempty
  }
  mappend a b = BuildExFlags {
    buildNumJobs = combine buildNumJobs,
    buildOnly    = combine buildOnly
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

testCommand :: CommandUI (TestFlags, BuildExFlags)
testCommand = 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.testCommand

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

benchmarkCommand :: CommandUI (BenchmarkFlags, BuildExFlags)
benchmarkCommand = parent {
  commandDefaultFlags = (commandDefaultFlags parent, mempty),
  commandOptions      =
    \showOrParseArgs -> liftOptions fst setFst
                        (commandOptions parent showOrParseArgs)
                        ++
                        liftOptions snd setSnd (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
417
  }
418
419
420
421
422
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

    parent = Cabal.benchmarkCommand
ttuegel's avatar
ttuegel committed
423

424
-- ------------------------------------------------------------
425
-- * Fetch command
426
-- ------------------------------------------------------------
427

428
429
430
431
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
432
      fetchSolver           :: Flag PreSolver,
433
434
435
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
436
      fetchShadowPkgs       :: Flag Bool,
437
438
439
440
441
442
443
444
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
445
446
447
448
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
    fetchReorderGoals     = Flag False,
    fetchIndependentGoals = Flag False,
449
    fetchShadowPkgs       = Flag False,
450
451
452
453
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
454
455
fetchCommand = CommandUI {
    commandName         = "fetch",
456
    commandSynopsis     = "Downloads packages for later installation.",
Duncan Coutts's avatar
Duncan Coutts committed
457
    commandDescription  = Nothing,
refold's avatar
refold committed
458
    commandUsage        = usagePackages "fetch",
459
    commandDefaultFlags = defaultFetchFlags,
460
    commandOptions      = \ showOrParseArgs -> [
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
         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
482
483
484
485

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
486
487
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
488
489
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
490
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
491

Duncan Coutts's avatar
Duncan Coutts committed
492
493
  }

494
495
496
497
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

498
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
499
500
501
502
updateCommand = CommandUI {
    commandName         = "update",
    commandSynopsis     = "Updates list of known packages",
    commandDescription  = Nothing,
refold's avatar
refold committed
503
    commandUsage        = usageFlags "update",
504
    commandDefaultFlags = toFlag normal,
505
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
506
507
  }

508
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
509
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
510
    commandName         = "upgrade",
511
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
512
    commandDescription  = Nothing,
refold's avatar
refold committed
513
    commandUsage        = usageFlagsOrPackages "upgrade",
514
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
515
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
516
517
  }

Duncan Coutts's avatar
Duncan Coutts committed
518
519
520
521
522
523
524
525
526
527
528
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

529
530
531
532
533
534
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
    commandSynopsis     = "Check the package for common mistakes",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
535
    commandDefaultFlags = toFlag normal,
536
    commandOptions      = \_ -> []
537
538
  }

539
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
540
541
542
543
544
runCommand = CommandUI {
    commandName         = "run",
    commandSynopsis     = "Runs the compiled executable.",
    commandDescription  = Nothing,
    commandUsage        =
545
546
547
      \pname -> "Usage: " ++ pname
                ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"
                ++ "Flags for run:",
refold's avatar
refold committed
548
    commandDefaultFlags = mempty,
549
550
551
552
553
554
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
                          (Cabal.buildOptions progConf showOrParseArgs)
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
555
556
  }
  where
557
558
559
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

refold's avatar
refold committed
560
561
    progConf = defaultProgramConfiguration

562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
-- ------------------------------------------------------------
-- * 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
580
581
582
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
    commandDescription  = Just $ \_ ->
         "You can store your Hackage login in the ~/.cabal/config file\n",
    commandUsage        = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"
      ++ "Flags for upload:",
    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))
      ]
603
604
  }

605
606
607
608
609
610
611
612
613
614
615
616
617
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

618
-- ------------------------------------------------------------
619
-- * Get flags
620
621
-- ------------------------------------------------------------

622
623
624
625
626
627
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
628

629
630
631
632
633
634
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
635
636
   }

637
638
639
640
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
    commandSynopsis     = "Gets a package's source code.",
641
642
643
644
645
    commandDescription  = Just $ \_ ->
          "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",
646
    commandUsage        = usagePackages "get",
647
648
    commandDefaultFlags = mempty,
    commandOptions      = \_ -> [
649
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
650
651

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

656
       ,option "s" ["source-repository"]
657
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
658
659
660
661
662
663
         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))

664
665
666
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
667
           getPristine (\v flags -> flags { getPristine = v })
668
           trueArg
669
670
671
       ]
  }

672
673
674
675
676
677
678
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
unpackCommand = getCommand {
  commandName  = "unpack",
  commandUsage = usagePackages "unpack"
  }

679
680
681
682
683
684
685
instance Monoid GetFlags where
  mempty = defaultGetFlags
  mappend a b = GetFlags {
    getDestDir          = combine getDestDir,
    getPristine         = combine getPristine,
    getSourceRepository = combine getSourceRepository,
    getVerbosity        = combine getVerbosity
686
687
688
  }
    where combine field = field a `mappend` field b

689
690
691
692
693
694
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
695
    listSimpleOutput :: Flag Bool,
696
697
698
699
700
701
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
702
    listSimpleOutput = Flag False,
703
704
705
706
707
708
    listVerbosity = toFlag normal
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
709
    commandSynopsis     = "List packages matching a search string.",
710
    commandDescription  = Nothing,
refold's avatar
refold committed
711
    commandUsage        = usageFlagsOrPackages "list",
712
    commandDefaultFlags = defaultListFlags,
713
    commandOptions      = \_ -> [
714
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
715

716
        , option [] ["installed"]
717
718
719
720
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

721
722
723
724
725
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

726
727
728
729
730
731
732
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
733
    listSimpleOutput = combine listSimpleOutput,
734
735
736
737
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
-- ------------------------------------------------------------
-- * Info flags
-- ------------------------------------------------------------

data InfoFlags = InfoFlags {
    infoVerbosity :: Flag Verbosity
  }

defaultInfoFlags :: InfoFlags
defaultInfoFlags = InfoFlags {
    infoVerbosity = toFlag normal
  }

infoCommand  :: CommandUI InfoFlags
infoCommand = CommandUI {
    commandName         = "info",
    commandSynopsis     = "Display detailed information about a particular package.",
    commandDescription  = Nothing,
refold's avatar
refold committed
756
    commandUsage        = usagePackages "info",
757
758
759
760
761
762
763
764
765
766
767
768
769
    commandDefaultFlags = defaultInfoFlags,
    commandOptions      = \_ -> [
        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })
        ]
  }

instance Monoid InfoFlags where
  mempty = defaultInfoFlags
  mappend a b = InfoFlags {
    infoVerbosity = combine infoVerbosity
  }
    where combine field = field a `mappend` field b

770
771
772
773
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

774
775
-- | Install takes the same flags as configure along with a few extras.
--
776
data InstallFlags = InstallFlags {
777
778
779
    installDocumentation    :: Flag Bool,
    installHaddockIndex     :: Flag PathTemplate,
    installDryRun           :: Flag Bool,
780
781
782
    installMaxBackjumps     :: Flag Int,
    installReorderGoals     :: Flag Bool,
    installIndependentGoals :: Flag Bool,
783
    installShadowPkgs       :: Flag Bool,
784
785
    installReinstall        :: Flag Bool,
    installAvoidReinstalls  :: Flag Bool,
786
    installOverrideReinstall :: Flag Bool,
787
788
789
790
791
792
793
794
    installUpgradeDeps      :: Flag Bool,
    installOnly             :: Flag Bool,
    installOnlyDeps         :: Flag Bool,
    installRootCmd          :: Flag String,
    installSummaryFile      :: [PathTemplate],
    installLogFile          :: Flag PathTemplate,
    installBuildReports     :: Flag ReportLevel,
    installSymlinkBinDir    :: Flag FilePath,
795
    installOneShot          :: Flag Bool,
796
    installNumJobs          :: Flag (Maybe Int)
797
798
799
800
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
801
802
803
    installDocumentation   = Flag False,
    installHaddockIndex    = Flag docIndexFile,
    installDryRun          = Flag False,
804
805
806
    installMaxBackjumps    = Flag defaultMaxBackjumps,
    installReorderGoals    = Flag False,
    installIndependentGoals= Flag False,
807
    installShadowPkgs      = Flag False,
808
809
    installReinstall       = Flag False,
    installAvoidReinstalls = Flag False,
810
    installOverrideReinstall = Flag False,
811
812
813
814
815
816
817
818
    installUpgradeDeps     = Flag False,
    installOnly            = Flag False,
    installOnlyDeps        = Flag False,
    installRootCmd         = mempty,
    installSummaryFile     = mempty,
    installLogFile         = mempty,
    installBuildReports    = Flag NoReports,
    installSymlinkBinDir   = mempty,
819
    installOneShot         = Flag False,
820
    installNumJobs         = mempty
821
  }
822
823
  where
    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
824

825
826
827
defaultMaxBackjumps :: Int
defaultMaxBackjumps = 200

828
829
defaultSolver :: PreSolver
defaultSolver = Choose
830
831

allSolvers :: String
832
allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver]))
833

834
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
835
installCommand = CommandUI {
836
837
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
refold's avatar
refold committed
838
  commandUsage        = usageFlagsOrPackages "install",
839
840
841
842
843
  commandDescription  = Just $ \pname ->
    let original = case commandDescription configureCommand of
          Just desc -> desc pname ++ "\n"
          Nothing   -> ""
     in original
844
     ++ "Examples:\n"
845
846
847
848
849
850
851
852
     ++ "  " ++ pname ++ " install                 "
     ++ "    Package in the current directory\n"
     ++ "  " ++ pname ++ " install foo             "
     ++ "    Package from the hackage server\n"
     ++ "  " ++ pname ++ " install foo-1.0         "
     ++ "    Specific version of a package\n"
     ++ "  " ++ pname ++ " install 'foo < 2'       "
     ++ "    Constrained package version\n",
853
  commandDefaultFlags = (mempty, mempty, mempty, mempty),
854
  commandOptions      = \showOrParseArgs ->
855
856
       liftOptions get1 set1 (filter ((/="constraint") . optionName) $
                              configureOptions   showOrParseArgs)
857
858
    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)
859
    ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)
860
  }
861
  where
862
863
864
865
866
    get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d)
    get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d)
    get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)
    get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d)

867
868
869
870
871
872
873
874
875
876
877
878
879
haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]
haddockOptions showOrParseArgs
  = [ opt { optionName = "haddock-" ++ name,
            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr
                          | descr <- optionDescr opt] }
    | opt <- commandOptions Cabal.haddockCommand showOrParseArgs
    , let name = optionName opt
    , name `elem` ["hoogle", "html", "html-location",
                   "executables", "internal", "css",
                   "hyperlink-source", "hscolour-css",
                   "contents-location"]
    ]
  where
880
881
882
883
884
    fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a
    fmapOptFlags modify (ReqArg d f p r w)    = ReqArg d (modify f) p r w
    fmapOptFlags modify (OptArg d f p r i w)  = OptArg d (modify f) p r i w
    fmapOptFlags modify (ChoiceOpt xs)        = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]
    fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w
885
886
887
888

installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
      [ option "" ["documentation"]
889
890
891
892
          "building of documentation"
          installDocumentation (\v flags -> flags { installDocumentation = v })
          (boolOpt [] [])

893
894
      , option [] ["doc-index-file"]
          "A central index of haddock API documentation (template cannot use $pkgid)"
895
896
897
          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
898

899
      , option [] ["dry-run"]
900
901
902
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
903
      ] ++
904

905
906
      optionSolverFlags showOrParseArgs
                        installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })
907
                        installReorderGoals     (\v flags -> flags { installReorderGoals     = v })
908
909
                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) ++
910

911
      [ option [] ["reinstall"]
912
913
          "Install even if it means installing the same version again."
          installReinstall (\v flags -> flags { installReinstall = v })
914
          (yesNoOpt showOrParseArgs)
915

916
917
918
      , option [] ["avoid-reinstalls"]
          "Do not select versions that would destructively overwrite installed packages."
          installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v })
919
          (yesNoOpt showOrParseArgs)
920

921
      , option [] ["force-reinstalls"]
922
          "Reinstall packages even if they will most likely break other installed packages."
923
          installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })
924
          (yesNoOpt showOrParseArgs)
925

926
927
928
      , option [] ["upgrade-dependencies"]
          "Pick the latest version for all dependencies, rather than trying to pick an installed version."
          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })
929
          (yesNoOpt showOrParseArgs)
930

931
932
933
      , option [] ["only-dependencies"]
          "Install only the dependencies necessary to build the given packages"
          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
934
          (yesNoOpt showOrParseArgs)
935

936
937
938
939
940
      , option [] ["dependencies-only"]
          "A synonym for --only-dependencies"
          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
          (yesNoOpt showOrParseArgs)

941
942
943
944
945
      , option [] ["root-cmd"]
          "Command used to gain root privileges, when installing with --global."
          installRootCmd (\v flags -> flags { installRootCmd = v })
          (reqArg' "COMMAND" toFlag flagToList)

946
947
948
949
950
      , option [] ["symlink-bindir"]
          "Add symlinks to installed executables into this directory."
           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })
           (reqArgFlag "DIR")

951
952
953
954
955
956
      , option [] ["build-summary"]
          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"
          installSummaryFile (\v flags -> flags { installSummaryFile = v })
          (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate))

      , option [] ["build-log"]
Duncan Coutts's avatar
Duncan Coutts committed
957
958
          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"
          installLogFile (\v flags -> flags { installLogFile = v })
959
960
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
Duncan Coutts's avatar
Duncan Coutts committed
961

962
963
      , option [] ["remote-build-reporting"]
          "Generate build reports to send to a remote server (none, anonymous or detailed)."
964
          installBuildReports (\v flags -> flags { installBuildReports = v })
965
966
967
968
          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "
                                            ++ "'anonymous' or 'detailed'")
                                      (toFlag `fmap` parse))
                          (flagToList . fmap display))
969

970
971
972
      , option [] ["one-shot"]
          "Do not record the packages in the world file."
          installOneShot (\v flags -> flags { installOneShot = v })
973
          (yesNoOpt showOrParseArgs)
974
975

      , option "j" ["jobs"]
976
        "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
977
        installNumJobs (\v flags -> flags { installNumJobs = v })
978
        (optArg "NUM" (fmap Flag numJobsParser)
979
                      (Flag Nothing)
980
                      (map (Just . maybe "$ncpus" show) . flagToList))
981
982
      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"
                                        -- avoids
983
          ParseArgs ->
EyalLotem's avatar
EyalLotem committed
984
            [ option [] ["only"]
985
986
              "Only installs the package in the current directory."
              installOnly (\v flags -> flags { installOnly = v })
EyalLotem's avatar
EyalLotem committed
987
              trueArg ]
988
          _ -> []
989

990
991

instance Monoid InstallFlags where
992
  mempty = InstallFlags {
993
994
995
996
997
    installDocumentation   = mempty,
    installHaddockIndex    = mempty,
    installDryRun          = mempty,
    installReinstall       = mempty,
    installAvoidReinstalls = mempty,
998
    installOverrideReinstall = mempty,
Andres Löh's avatar
Andres Löh committed
999
    installMaxBackjumps    = mempty,
1000
    installUpgradeDeps     = mempty,