Setup.hs 56.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(..), globalRepos
15
    , configureCommand, ConfigFlags(..), filterConfigureFlags
16
17
    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
                        , configureExOptions
ttuegel's avatar
ttuegel committed
18
    , buildCommand, BuildFlags(..)
19
    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
20
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
21
    , updateCommand
ijones's avatar
ijones committed
22
    , upgradeCommand
23
    , infoCommand, InfoFlags(..)
24
    , fetchCommand, FetchFlags(..)
25
    , checkCommand
26
    , uploadCommand, UploadFlags(..)
27
    , reportCommand, ReportFlags(..)
28
    , unpackCommand, UnpackFlags(..)
29
    , initCommand, IT.InitFlags(..)
30
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
31
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
32
    , indexCommand, IndexFlags(..)
refold's avatar
refold committed
33
    , dumpPkgEnvCommand
refold's avatar
refold committed
34
35
    , sandboxInitCommand, sandboxDeleteCommand, sandboxConfigureCommand
    , sandboxAddSourceCommand, sandboxBuildCommand, sandboxInstallCommand
refold's avatar
refold committed
36
    , SandboxFlags(..), defaultSandboxLocation
Duncan Coutts's avatar
Duncan Coutts committed
37
38

    , parsePackageArgs
39
40
41
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
42
43
    ) where

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

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

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

98
99
100
101
102
103
104
105
106
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

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

114
115
116
117
118
119
120
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
    globalVersion        = Flag False,
    globalNumericVersion = Flag False,
    globalConfigFile     = mempty,
    globalRemoteRepos    = [],
    globalCacheDir       = mempty,
121
    globalLocalRepos     = mempty,
122
    globalLogsDir        = mempty,
123
    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
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
    commandDefaultFlags = defaultGlobalFlags,
    commandOptions      = \showOrParseArgs ->
      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)
      [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")

      ,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)
173

174
175
176
177
178
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

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

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
    globalVersion        = mempty,
    globalNumericVersion = mempty,
    globalConfigFile     = mempty,
    globalRemoteRepos    = mempty,
    globalCacheDir       = mempty,
193
    globalLocalRepos     = mempty,
194
    globalLogsDir        = mempty,
195
    globalWorldFile      = mempty
196
197
198
199
200
201
202
  }
  mappend a b = GlobalFlags {
    globalVersion        = combine globalVersion,
    globalNumericVersion = combine globalNumericVersion,
    globalConfigFile     = combine globalConfigFile,
    globalRemoteRepos    = combine globalRemoteRepos,
    globalCacheDir       = combine globalCacheDir,
203
    globalLocalRepos     = combine globalLocalRepos,
204
    globalLogsDir        = combine globalLogsDir,
205
    globalWorldFile      = combine globalWorldFile
Duncan Coutts's avatar
Duncan Coutts committed
206
  }
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
    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
224

225
configureCommand :: CommandUI ConfigFlags
226
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
227
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
228
229
  }

230
231
232
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

233
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
234
235
236
filterConfigureFlags flags cabalLibVersion
  | cabalLibVersion >= Version [1,3,10] [] = flags
    -- older Cabal does not grok the constraints flag:
237
  | otherwise = flags { configConstraints = [] }
238

239
240
241
242
243
244
245
246
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
247
    configExConstraints:: [UserConstraint],
248
    configPreferences  :: [Dependency],
249
    configSolver       :: Flag PreSolver
250
251
252
  }

defaultConfigExFlags :: ConfigExFlags
253
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }
254
255
256
257
258

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
259
260
         liftOptions fst setFst (filter ((/="constraint") . optionName) $
                                 configureOptions   showOrParseArgs)
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
      ++ 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))
276
277
278
279
280
281
  , 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))
282
283
284
285

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
286
287
288
289
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
290
291

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
292
293
294
295
296
  ]

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
297
    configExConstraints= mempty,
298
299
    configPreferences  = mempty,
    configSolver       = mempty
300
301
302
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
303
    configExConstraints= combine configExConstraints,
304
305
    configPreferences  = combine configPreferences,
    configSolver       = combine configSolver
306
307
308
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
309
310
311
312
313
314
315
316
317
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

buildCommand :: CommandUI BuildFlags
buildCommand = (Cabal.buildCommand defaultProgramConfiguration) {
    commandDefaultFlags = mempty
  }

318
-- ------------------------------------------------------------
319
-- * Fetch command
320
-- ------------------------------------------------------------
321

322
323
324
325
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
326
      fetchSolver           :: Flag PreSolver,
327
328
329
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
330
      fetchShadowPkgs       :: Flag Bool,
331
332
333
334
335
336
337
338
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
339
340
341
342
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
    fetchReorderGoals     = Flag False,
    fetchIndependentGoals = Flag False,
343
    fetchShadowPkgs       = Flag False,
344
345
346
347
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
348
349
fetchCommand = CommandUI {
    commandName         = "fetch",
350
    commandSynopsis     = "Downloads packages for later installation.",
Duncan Coutts's avatar
Duncan Coutts committed
351
352
    commandDescription  = Nothing,
    commandUsage        = usagePackages "fetch",
353
    commandDefaultFlags = defaultFetchFlags,
354
    commandOptions      = \ showOrParseArgs -> [
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
         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
376
377
378
379

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
380
381
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
382
383
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
384
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
385

Duncan Coutts's avatar
Duncan Coutts committed
386
387
  }

388
389
390
391
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

392
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
393
394
395
396
397
updateCommand = CommandUI {
    commandName         = "update",
    commandSynopsis     = "Updates list of known packages",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "update",
398
    commandDefaultFlags = toFlag normal,
399
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
400
401
  }

402
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
403
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
404
    commandName         = "upgrade",
405
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
406
    commandDescription  = Nothing,
407
    commandUsage        = usagePackages "upgrade",
408
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
409
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
410
411
  }

Duncan Coutts's avatar
Duncan Coutts committed
412
413
414
415
416
417
418
419
420
421
422
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

423
424
425
426
427
428
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
    commandSynopsis     = "Check the package for common mistakes",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
429
    commandDefaultFlags = toFlag normal,
430
    commandOptions      = \_ -> []
431
432
  }

433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
-- ------------------------------------------------------------
-- * 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
451
452
453
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
    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))
      ]
474
475
  }

476
477
478
479
480
481
482
483
484
485
486
487
488
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

489
490
491
492
493
494
-- ------------------------------------------------------------
-- * Unpack flags
-- ------------------------------------------------------------

data UnpackFlags = UnpackFlags {
      unpackDestDir :: Flag FilePath,
495
496
      unpackVerbosity :: Flag Verbosity,
      unpackPristine :: Flag Bool
497
498
499
500
501
    }

defaultUnpackFlags :: UnpackFlags
defaultUnpackFlags = UnpackFlags {
    unpackDestDir = mempty,
502
503
    unpackVerbosity = toFlag normal,
    unpackPristine  = toFlag False
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
   }

unpackCommand :: CommandUI UnpackFlags
unpackCommand = CommandUI {
    commandName         = "unpack",
    commandSynopsis     = "Unpacks packages for user inspection.",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "unpack",
    commandDefaultFlags = mempty,
    commandOptions      = \_ -> [
        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })

       ,option "d" ["destdir"]
         "where to unpack the packages, defaults to the current directory."
         unpackDestDir (\v flags -> flags { unpackDestDir = v })
         (reqArgFlag "PATH")
520
521
522
523
524
525

       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
           unpackPristine (\v flags -> flags { unpackPristine = v })
           trueArg
526
527
528
529
530
531
       ]
  }

instance Monoid UnpackFlags where
  mempty = defaultUnpackFlags
  mappend a b = UnpackFlags {
532
533
534
    unpackDestDir   = combine unpackDestDir,
    unpackVerbosity = combine unpackVerbosity,
    unpackPristine  = combine unpackPristine
535
536
537
  }
    where combine field = field a `mappend` field b

538
539
540
541
542
543
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
544
    listSimpleOutput :: Flag Bool,
545
546
547
548
549
550
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
551
    listSimpleOutput = Flag False,
552
553
554
555
556
557
    listVerbosity = toFlag normal
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
558
    commandSynopsis     = "List packages matching a search string.",
559
560
    commandDescription  = Nothing,
    commandUsage        = usagePackages "list",
561
    commandDefaultFlags = defaultListFlags,
562
    commandOptions      = \_ -> [
563
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
564

565
        , option [] ["installed"]
566
567
568
569
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

570
571
572
573
574
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

575
576
577
578
579
580
581
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
582
    listSimpleOutput = combine listSimpleOutput,
583
584
585
586
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
-- ------------------------------------------------------------
-- * 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,
    commandUsage        = usagePackages "info",
    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

619
620
621
622
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

623
624
-- | Install takes the same flags as configure along with a few extras.
--
625
data InstallFlags = InstallFlags {
626
627
628
    installDocumentation    :: Flag Bool,
    installHaddockIndex     :: Flag PathTemplate,
    installDryRun           :: Flag Bool,
629
630
631
    installMaxBackjumps     :: Flag Int,
    installReorderGoals     :: Flag Bool,
    installIndependentGoals :: Flag Bool,
632
    installShadowPkgs       :: Flag Bool,
633
634
    installReinstall        :: Flag Bool,
    installAvoidReinstalls  :: Flag Bool,
635
    installOverrideReinstall :: Flag Bool,
636
637
638
639
640
641
642
643
    installUpgradeDeps      :: Flag Bool,
    installOnly             :: Flag Bool,
    installOnlyDeps         :: Flag Bool,
    installRootCmd          :: Flag String,
    installSummaryFile      :: [PathTemplate],
    installLogFile          :: Flag PathTemplate,
    installBuildReports     :: Flag ReportLevel,
    installSymlinkBinDir    :: Flag FilePath,
644
    installOneShot          :: Flag Bool,
645
    installNumJobs          :: Flag (Maybe Int)
646
647
648
649
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
650
651
652
    installDocumentation   = Flag False,
    installHaddockIndex    = Flag docIndexFile,
    installDryRun          = Flag False,
653
654
655
    installMaxBackjumps    = Flag defaultMaxBackjumps,
    installReorderGoals    = Flag False,
    installIndependentGoals= Flag False,
656
    installShadowPkgs      = Flag False,
657
658
    installReinstall       = Flag False,
    installAvoidReinstalls = Flag False,
659
    installOverrideReinstall = Flag False,
660
661
662
663
664
665
666
667
    installUpgradeDeps     = Flag False,
    installOnly            = Flag False,
    installOnlyDeps        = Flag False,
    installRootCmd         = mempty,
    installSummaryFile     = mempty,
    installLogFile         = mempty,
    installBuildReports    = Flag NoReports,
    installSymlinkBinDir   = mempty,
668
    installOneShot         = Flag False,
669
    installNumJobs         = mempty
670
  }
671
672
  where
    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
673

674
675
676
defaultMaxBackjumps :: Int
defaultMaxBackjumps = 200

677
678
defaultSolver :: PreSolver
defaultSolver = Choose
679
680

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

683
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
684
installCommand = CommandUI {
685
686
687
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
688
689
690
691
692
  commandDescription  = Just $ \pname ->
    let original = case commandDescription configureCommand of
          Just desc -> desc pname ++ "\n"
          Nothing   -> ""
     in original
693
     ++ "Examples:\n"
694
695
696
697
698
699
700
701
     ++ "  " ++ 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",
702
  commandDefaultFlags = (mempty, mempty, mempty, mempty),
703
  commandOptions      = \showOrParseArgs ->
704
705
       liftOptions get1 set1 (filter ((/="constraint") . optionName) $
                              configureOptions   showOrParseArgs)
706
707
    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)
708
    ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)
709
  }
710
  where
711
712
713
714
715
    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)

716
717
718
719
720
721
722
723
724
725
726
727
728
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
729
730
731
732
733
    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
734
735
736
737

installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
      [ option "" ["documentation"]
738
739
740
741
          "building of documentation"
          installDocumentation (\v flags -> flags { installDocumentation = v })
          (boolOpt [] [])

742
743
      , option [] ["doc-index-file"]
          "A central index of haddock API documentation (template cannot use $pkgid)"
744
745
746
          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
747

748
      , option [] ["dry-run"]
749
750
751
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
752
      ] ++
753

754
755
      optionSolverFlags showOrParseArgs
                        installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })
756
                        installReorderGoals     (\v flags -> flags { installReorderGoals     = v })
757
758
                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) ++
759

760
      [ option [] ["reinstall"]
761
762
          "Install even if it means installing the same version again."
          installReinstall (\v flags -> flags { installReinstall = v })
763
          (yesNoOpt showOrParseArgs)
764

765
766
767
      , option [] ["avoid-reinstalls"]
          "Do not select versions that would destructively overwrite installed packages."
          installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v })
768
          (yesNoOpt showOrParseArgs)
769

770
      , option [] ["force-reinstalls"]
771
          "Reinstall packages even if they will most likely break other installed packages."
772
          installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })
773
          (yesNoOpt showOrParseArgs)
774

775
776
777
      , option [] ["upgrade-dependencies"]
          "Pick the latest version for all dependencies, rather than trying to pick an installed version."
          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })
778
          (yesNoOpt showOrParseArgs)
779

780
781
782
      , option [] ["only-dependencies"]
          "Install only the dependencies necessary to build the given packages"
          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
783
          (yesNoOpt showOrParseArgs)
784

785
786
787
788
789
      , option [] ["root-cmd"]
          "Command used to gain root privileges, when installing with --global."
          installRootCmd (\v flags -> flags { installRootCmd = v })
          (reqArg' "COMMAND" toFlag flagToList)

790
791
792
793
794
      , option [] ["symlink-bindir"]
          "Add symlinks to installed executables into this directory."
           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })
           (reqArgFlag "DIR")

795
796
797
798
799
800
      , 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
801
802
          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"
          installLogFile (\v flags -> flags { installLogFile = v })
803
804
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
Duncan Coutts's avatar
Duncan Coutts committed
805

806
807
      , option [] ["remote-build-reporting"]
          "Generate build reports to send to a remote server (none, anonymous or detailed)."
808
          installBuildReports (\v flags -> flags { installBuildReports = v })
809
810
811
812
          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "
                                            ++ "'anonymous' or 'detailed'")
                                      (toFlag `fmap` parse))
                          (flagToList . fmap display))
813

814
815
816
      , option [] ["one-shot"]
          "Do not record the packages in the world file."
          installOneShot (\v flags -> flags { installOneShot = v })
817
          (yesNoOpt showOrParseArgs)
818
819

      , option "j" ["jobs"]
820
        "Run NUM jobs simultaneously."
821
        installNumJobs (\v flags -> flags { installNumJobs = v })
822
823
824
825
826
        (optArg "NUM" (readP_to_E (\_ -> "jobs should be a number")
                                  (fmap (toFlag . Just)
                                        (Parse.readS_to_P reads)))
                      (Flag Nothing)
                      (map (fmap show) . flagToList))
827
828
829
830
831
832
833
      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids
          ParseArgs ->
            option [] ["only"]
              "Only installs the package in the current directory."
              installOnly (\v flags -> flags { installOnly = v })
              trueArg
             : []
834
          _ -> []
835
836

instance Monoid InstallFlags where
837
  mempty = InstallFlags {
838
839
840
841
842
    installDocumentation   = mempty,
    installHaddockIndex    = mempty,
    installDryRun          = mempty,
    installReinstall       = mempty,
    installAvoidReinstalls = mempty,
843
    installOverrideReinstall = mempty,
Andres Löh's avatar
Andres Löh committed
844
    installMaxBackjumps    = mempty,
845
    installUpgradeDeps     = mempty,
Andres Löh's avatar
Andres Löh committed
846
    installReorderGoals    = mempty,
847
    installIndependentGoals= mempty,
848
    installShadowPkgs      = mempty,
849
850
851
852
853
854
855
    installOnly            = mempty,
    installOnlyDeps        = mempty,
    installRootCmd         = mempty,
    installSummaryFile     = mempty,
    installLogFile         = mempty,
    installBuildReports    = mempty,
    installSymlinkBinDir   = mempty,
856
857
    installOneShot         = mempty,
    installNumJobs         = mempty
858
  }
859
  mappend a b = InstallFlags {
860
861
862
863
864
    installDocumentation   = combine installDocumentation,
    installHaddockIndex    = combine installHaddockIndex,
    installDryRun          = combine installDryRun,
    installReinstall       = combine installReinstall,
    installAvoidReinstalls = combine installAvoidReinstalls,
865
    installOverrideReinstall = combine installOverrideReinstall,
Andres Löh's avatar
Andres Löh committed
866
    installMaxBackjumps    = combine installMaxBackjumps,
867
    installUpgradeDeps     = combine installUpgradeDeps,
Andres Löh's avatar
Andres Löh committed
868
    installReorderGoals    = combine installReorderGoals,
869
    installIndependentGoals= combine installIndependentGoals,
870
    installShadowPkgs      = combine installShadowPkgs,
871
872
873
874
875
876
877
    installOnly            = combine installOnly,
    installOnlyDeps        = combine installOnlyDeps,
    installRootCmd         = combine installRootCmd,
    installSummaryFile     = combine installSummaryFile,
    installLogFile         = combine installLogFile,
    installBuildReports    = combine installBuildReports,
    installSymlinkBinDir   = combine installSymlinkBinDir,
878
879
    installOneShot         = combine installOneShot,
    installNumJobs         = combine installNumJobs
880
881
882
  }
    where combine field = field a `mappend` field b

883
884
885
886
887
888
889
890
891
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
892
  }
893
894
895
896
897
898
899
900
901
902
903
904
905
906

defaultUploadFlags :: UploadFlags
defaultUploadFlags = UploadFlags {
    uploadCheck     = toFlag False,
    uploadUsername  = mempty,
    uploadPassword  = mempty,
    uploadVerbosity = toFlag normal
  }

uploadCommand :: CommandUI UploadFlags
uploadCommand = CommandUI {
    commandName         = "upload",
    commandSynopsis     = "Uploads source packages to Hackage",
    commandDescription  = Just $ \_ ->
907
         "You can store your Hackage login in the ~/.cabal/config file\n",
908
909
910
911
912
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
913
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
914
915
916
917

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
918
        trueArg
919
920
921
922

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
923
924
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
925
926
927
928

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
929
930
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
      ]
  }

instance Monoid UploadFlags where
  mempty = UploadFlags {
    uploadCheck     = mempty,
    uploadUsername  = mempty,
    uploadPassword  = mempty,
    uploadVerbosity = mempty
  }
  mappend a b = UploadFlags {
    uploadCheck     = combine uploadCheck,
    uploadUsername  = combine uploadUsername,
    uploadPassword  = combine uploadPassword,
    uploadVerbosity = combine uploadVerbosity
  }
    where combine field = field a `mappend` field b

949
950
951
952
953
954
955
956
-- ------------------------------------------------------------
-- * Init flags
-- ------------------------------------------------------------

emptyInitFlags :: IT.InitFlags
emptyInitFlags  = mempty

defaultInitFlags :: IT.InitFlags
957
defaultInitFlags  = emptyInitFlags { IT.initVerbosity = toFlag normal }
958
959
960
961
962

initCommand :: CommandUI IT.InitFlags
initCommand = CommandUI {
    commandName = "init",
    commandSynopsis = "Interactively create a .cabal file.",
963
964
965
966
967
968
969
970
971
972
973
974
    commandDescription = Just $ \_ -> wrapText $
         "Cabalise a project by creating a .cabal, Setup.hs, and "
      ++ "optionally a LICENSE file.\n\n"
      ++ "Calling init with no arguments (recommended) uses an "
      ++ "interactive mode, which will try to guess as much as "
      ++ "possible and prompt you for the rest.  Command-line "
      ++ "arguments are provided for scripting purposes. "
      ++ "If you don't want interactive mode, be sure to pass "
      ++ "the -n flag.\n",
    commandUsage = \pname ->
         "Usage: " ++ pname ++ " init [FLAGS]\n\n"
      ++ "Flags for init:",
975
976
    commandDefaultFlags = defaultInitFlags,
    commandOptions = \_ ->
977
      [ option ['n'] ["non-interactive"]
978
979
980
981
982
983
984
985
986
        "Non-interactive mode."
        IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v })
        trueArg

      , option ['q'] ["quiet"]
        "Do not generate log messages to stdout."
        IT.quiet (\v flags -> flags { IT.quiet = v })
        trueArg

987
      , option [] ["no-comments"]
988
989
990
991
992
        "Do not generate explanatory comments in the .cabal file."
        IT.noComments (\v flags -> flags { IT.noComments = v })
        trueArg

      , option ['m'] ["minimal"]
993
        "Generate a minimal .cabal file, that is, do not include extra empty fields.  Also implies --no-comments."
994
995
996
        IT.minimal (\v flags -> flags { IT.minimal = v })
        trueArg

997
998
999
1000
      , option [] ["overwrite"]
        "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning."
        IT.overwrite (\v flags -> flags { IT.overwrite = v })
        trueArg