Setup.hs 58.8 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
    , getCommand, GetFlags(..)
26
    , checkCommand
27
    , uploadCommand, UploadFlags(..)
28
    , reportCommand, ReportFlags(..)
refold's avatar
refold committed
29
    , runCommand
30
    , initCommand, IT.InitFlags(..)
31
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
32
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
33
    , indexCommand, IndexFlags(..)
refold's avatar
refold committed
34
    , dumpPkgEnvCommand
refold's avatar
refold committed
35
36
    , sandboxInitCommand, sandboxDeleteCommand, sandboxConfigureCommand
    , sandboxAddSourceCommand, sandboxBuildCommand, sandboxInstallCommand
refold's avatar
refold committed
37
    , SandboxFlags(..), defaultSandboxLocation
Duncan Coutts's avatar
Duncan Coutts committed
38
39

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

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

import Distribution.Simple.Program
         ( defaultProgramConfiguration )
58
import Distribution.Simple.Command hiding (boolOpt)
Duncan Coutts's avatar
Duncan Coutts committed
59
import qualified Distribution.Simple.Setup as Cabal
60
import Distribution.Simple.Setup
EyalLotem's avatar
EyalLotem committed
61
62
         ( ConfigFlags(..), BuildFlags(..), SDistFlags(..), HaddockFlags(..)
         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
63
         , optionVerbosity, boolOpt, trueArg, falseArg )
64
65
import Distribution.Simple.InstallDirs
         ( PathTemplate, toPathTemplate, fromPathTemplate )
66
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
67
         ( Version(Version), anyVersion, thisVersion )
68
import Distribution.Package
69
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
70
71
import Distribution.PackageDescription
         ( RepoKind(..) )
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
    commandDefaultFlags = defaultGlobalFlags,
    commandOptions      = \showOrParseArgs ->
143
      (case showOrParseArgs of ShowArgs -> take 3; ParseArgs -> id)
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
      [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
filterConfigureFlags flags cabalLibVersion
235
236
237
238
239
240
241
242
243
244
245
246
247
248
  | cabalLibVersion >= Version [1,14,0] [] = flags
  | 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

  -- A no-op that silences the "pattern match is non-exhaustive" warning.
  | otherwise = flags
  where
    -- Cabal < 1.14.0 doesn't know about --disable-benchmarks.
    flags_1_14_0 = flags        { configBenchmarks  = NoFlag }
    -- 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 = [] }
249

250
251
252
253
254
255
256
257
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
258
    configExConstraints:: [UserConstraint],
259
    configPreferences  :: [Dependency],
260
    configSolver       :: Flag PreSolver
261
262
263
  }

defaultConfigExFlags :: ConfigExFlags
264
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }
265
266
267
268
269

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
270
271
         liftOptions fst setFst (filter ((/="constraint") . optionName) $
                                 configureOptions   showOrParseArgs)
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
      ++ 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))
287
288
289
290
291
292
  , 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))
293
294
295
296

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
297
298
299
300
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
301
302

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
303
304
305
306
307
  ]

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
308
    configExConstraints= mempty,
309
310
    configPreferences  = mempty,
    configSolver       = mempty
311
312
313
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
314
    configExConstraints= combine configExConstraints,
315
316
    configPreferences  = combine configPreferences,
    configSolver       = combine configSolver
317
318
319
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
320
321
322
323
324
325
326
327
328
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

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

329
-- ------------------------------------------------------------
330
-- * Fetch command
331
-- ------------------------------------------------------------
332

333
334
335
336
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
337
      fetchSolver           :: Flag PreSolver,
338
339
340
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
341
      fetchShadowPkgs       :: Flag Bool,
342
343
344
345
346
347
348
349
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
350
351
352
353
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
    fetchReorderGoals     = Flag False,
    fetchIndependentGoals = Flag False,
354
    fetchShadowPkgs       = Flag False,
355
356
357
358
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
359
360
fetchCommand = CommandUI {
    commandName         = "fetch",
361
    commandSynopsis     = "Downloads packages for later installation.",
Duncan Coutts's avatar
Duncan Coutts committed
362
363
    commandDescription  = Nothing,
    commandUsage        = usagePackages "fetch",
364
    commandDefaultFlags = defaultFetchFlags,
365
    commandOptions      = \ showOrParseArgs -> [
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
         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
387
388
389
390

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
391
392
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
393
394
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
395
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
396

Duncan Coutts's avatar
Duncan Coutts committed
397
398
  }

399
400
401
402
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

403
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
404
405
406
407
408
updateCommand = CommandUI {
    commandName         = "update",
    commandSynopsis     = "Updates list of known packages",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "update",
409
    commandDefaultFlags = toFlag normal,
410
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
411
412
  }

413
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
414
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
415
    commandName         = "upgrade",
416
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
417
    commandDescription  = Nothing,
418
    commandUsage        = usagePackages "upgrade",
419
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
420
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
421
422
  }

Duncan Coutts's avatar
Duncan Coutts committed
423
424
425
426
427
428
429
430
431
432
433
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

434
435
436
437
438
439
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
    commandSynopsis     = "Check the package for common mistakes",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
440
    commandDefaultFlags = toFlag normal,
441
    commandOptions      = \_ -> []
442
443
  }

refold's avatar
refold committed
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
runCommand :: CommandUI BuildFlags
runCommand = CommandUI {
    commandName         = "run",
    commandSynopsis     = "Runs the compiled executable.",
    commandDescription  = Nothing,
    commandUsage        =
      (\pname -> "Usage: " ++ pname
                 ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"
                 ++ "Flags for run:"),
    commandDefaultFlags = mempty,
    commandOptions      = Cabal.buildOptions progConf
  }
  where
    progConf = defaultProgramConfiguration

459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
-- ------------------------------------------------------------
-- * 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
477
478
479
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
    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))
      ]
500
501
  }

502
503
504
505
506
507
508
509
510
511
512
513
514
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

515
-- ------------------------------------------------------------
516
-- * Get flags
517
518
-- ------------------------------------------------------------

519
520
521
522
523
524
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
525

526
527
528
529
530
531
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
532
533
   }

534
535
536
537
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
    commandSynopsis     = "Gets a package's source code.",
538
    commandDescription  = Nothing,
539
    commandUsage        = usagePackages "get",
540
541
    commandDefaultFlags = mempty,
    commandOptions      = \_ -> [
542
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
543
544

       ,option "d" ["destdir"]
545
546
         "where to place the package source, defaults to the current directory."
         getDestDir (\v flags -> flags { getDestDir = v })
547
         (reqArgFlag "PATH")
548

549
550
551
552
553
554
555
556
       ,option "s" ["source-repository"]
         "fork the package's source repository."
         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))

557
558
559
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
560
           getPristine (\v flags -> flags { getPristine = v })
561
           trueArg
562
563
564
       ]
  }

565
566
567
568
569
570
571
instance Monoid GetFlags where
  mempty = defaultGetFlags
  mappend a b = GetFlags {
    getDestDir          = combine getDestDir,
    getPristine         = combine getPristine,
    getSourceRepository = combine getSourceRepository,
    getVerbosity        = combine getVerbosity
572
573
574
  }
    where combine field = field a `mappend` field b

575
576
577
578
579
580
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
581
    listSimpleOutput :: Flag Bool,
582
583
584
585
586
587
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
588
    listSimpleOutput = Flag False,
589
590
591
592
593
594
    listVerbosity = toFlag normal
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
595
    commandSynopsis     = "List packages matching a search string.",
596
597
    commandDescription  = Nothing,
    commandUsage        = usagePackages "list",
598
    commandDefaultFlags = defaultListFlags,
599
    commandOptions      = \_ -> [
600
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
601

602
        , option [] ["installed"]
603
604
605
606
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

607
608
609
610
611
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

612
613
614
615
616
617
618
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
619
    listSimpleOutput = combine listSimpleOutput,
620
621
622
623
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
-- ------------------------------------------------------------
-- * 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

656
657
658
659
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

660
661
-- | Install takes the same flags as configure along with a few extras.
--
662
data InstallFlags = InstallFlags {
663
664
665
    installDocumentation    :: Flag Bool,
    installHaddockIndex     :: Flag PathTemplate,
    installDryRun           :: Flag Bool,
666
667
668
    installMaxBackjumps     :: Flag Int,
    installReorderGoals     :: Flag Bool,
    installIndependentGoals :: Flag Bool,
669
    installShadowPkgs       :: Flag Bool,
670
671
    installReinstall        :: Flag Bool,
    installAvoidReinstalls  :: Flag Bool,
672
    installOverrideReinstall :: Flag Bool,
673
674
675
676
677
678
679
680
    installUpgradeDeps      :: Flag Bool,
    installOnly             :: Flag Bool,
    installOnlyDeps         :: Flag Bool,
    installRootCmd          :: Flag String,
    installSummaryFile      :: [PathTemplate],
    installLogFile          :: Flag PathTemplate,
    installBuildReports     :: Flag ReportLevel,
    installSymlinkBinDir    :: Flag FilePath,
681
    installOneShot          :: Flag Bool,
682
    installNumJobs          :: Flag (Maybe Int)
683
684
685
686
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
687
688
689
    installDocumentation   = Flag False,
    installHaddockIndex    = Flag docIndexFile,
    installDryRun          = Flag False,
690
691
692
    installMaxBackjumps    = Flag defaultMaxBackjumps,
    installReorderGoals    = Flag False,
    installIndependentGoals= Flag False,
693
    installShadowPkgs      = Flag False,
694
695
    installReinstall       = Flag False,
    installAvoidReinstalls = Flag False,
696
    installOverrideReinstall = Flag False,
697
698
699
700
701
702
703
704
    installUpgradeDeps     = Flag False,
    installOnly            = Flag False,
    installOnlyDeps        = Flag False,
    installRootCmd         = mempty,
    installSummaryFile     = mempty,
    installLogFile         = mempty,
    installBuildReports    = Flag NoReports,
    installSymlinkBinDir   = mempty,
705
    installOneShot         = Flag False,
706
    installNumJobs         = mempty
707
  }
708
709
  where
    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
710

711
712
713
defaultMaxBackjumps :: Int
defaultMaxBackjumps = 200

714
715
defaultSolver :: PreSolver
defaultSolver = Choose
716
717

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

720
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
721
installCommand = CommandUI {
722
723
724
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
725
726
727
728
729
  commandDescription  = Just $ \pname ->
    let original = case commandDescription configureCommand of
          Just desc -> desc pname ++ "\n"
          Nothing   -> ""
     in original
730
     ++ "Examples:\n"
731
732
733
734
735
736
737
738
     ++ "  " ++ 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",
739
  commandDefaultFlags = (mempty, mempty, mempty, mempty),
740
  commandOptions      = \showOrParseArgs ->
741
742
       liftOptions get1 set1 (filter ((/="constraint") . optionName) $
                              configureOptions   showOrParseArgs)
743
744
    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)
745
    ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)
746
  }
747
  where
748
749
750
751
752
    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)

753
754
755
756
757
758
759
760
761
762
763
764
765
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
766
767
768
769
770
    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
771
772
773
774

installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
      [ option "" ["documentation"]
775
776
777
778
          "building of documentation"
          installDocumentation (\v flags -> flags { installDocumentation = v })
          (boolOpt [] [])

779
780
      , option [] ["doc-index-file"]
          "A central index of haddock API documentation (template cannot use $pkgid)"
781
782
783
          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
784

785
      , option [] ["dry-run"]
786
787
788
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
789
      ] ++
790

791
792
      optionSolverFlags showOrParseArgs
                        installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })
793
                        installReorderGoals     (\v flags -> flags { installReorderGoals     = v })
794
795
                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) ++
796

797
      [ option [] ["reinstall"]
798
799
          "Install even if it means installing the same version again."
          installReinstall (\v flags -> flags { installReinstall = v })
800
          (yesNoOpt showOrParseArgs)
801

802
803
804
      , option [] ["avoid-reinstalls"]
          "Do not select versions that would destructively overwrite installed packages."
          installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v })
805
          (yesNoOpt showOrParseArgs)
806

807
      , option [] ["force-reinstalls"]
808
          "Reinstall packages even if they will most likely break other installed packages."
809
          installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })
810
          (yesNoOpt showOrParseArgs)
811

812
813
814
      , option [] ["upgrade-dependencies"]
          "Pick the latest version for all dependencies, rather than trying to pick an installed version."
          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })
815
          (yesNoOpt showOrParseArgs)
816

817
818
819
      , option [] ["only-dependencies"]
          "Install only the dependencies necessary to build the given packages"
          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
820
          (yesNoOpt showOrParseArgs)
821

822
823
824
825
826
      , option [] ["dependencies-only"]
          "A synonym for --only-dependencies"
          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
          (yesNoOpt showOrParseArgs)

827
828
829
830
831
      , option [] ["root-cmd"]
          "Command used to gain root privileges, when installing with --global."
          installRootCmd (\v flags -> flags { installRootCmd = v })
          (reqArg' "COMMAND" toFlag flagToList)

832
833
834
835
836
      , option [] ["symlink-bindir"]
          "Add symlinks to installed executables into this directory."
           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })
           (reqArgFlag "DIR")

837
838
839
840
841
842
      , 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
843
844
          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"
          installLogFile (\v flags -> flags { installLogFile = v })
845
846
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
Duncan Coutts's avatar
Duncan Coutts committed
847

848
849
      , option [] ["remote-build-reporting"]
          "Generate build reports to send to a remote server (none, anonymous or detailed)."
850
          installBuildReports (\v flags -> flags { installBuildReports = v })
851
852
853
854
          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "
                                            ++ "'anonymous' or 'detailed'")
                                      (toFlag `fmap` parse))
                          (flagToList . fmap display))
855

856
857
858
      , option [] ["one-shot"]
          "Do not record the packages in the world file."
          installOneShot (\v flags -> flags { installOneShot = v })
859
          (yesNoOpt showOrParseArgs)
860
861

      , option "j" ["jobs"]
862
        "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
863
        installNumJobs (\v flags -> flags { installNumJobs = v })
864
        (optArg "NUM" (fmap Flag flagToJobs)
865
                      (Flag Nothing)
866
                      (map (Just . maybe "$ncpus" show) . flagToList))
867
868
      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids
          ParseArgs ->
EyalLotem's avatar
EyalLotem committed
869
            [ option [] ["only"]
870
871
              "Only installs the package in the current directory."
              installOnly (\v flags -> flags { installOnly = v })
EyalLotem's avatar
EyalLotem committed
872
              trueArg ]
873
          _ -> []
874
875
876
877
878
  where
    flagToJobs :: ReadE (Maybe Int)
    flagToJobs = ReadE $ \s ->
      case s of
        "$ncpus" -> Right Nothing
879
        _        -> case reads s of
880
881
882
883
884
885
          [(n, "")]
            | n < 1     -> Left "The number of jobs should be 1 or more."
            | n > 64    -> Left "You probably don't want that many jobs."
            | otherwise -> Right (Just n)
          _             -> Left "The jobs value should be a number or '$ncpus'"

886
887

instance Monoid InstallFlags where
888
  mempty = InstallFlags {
889
890
891
892
893
    installDocumentation   = mempty,
    installHaddockIndex    = mempty,
    installDryRun          = mempty,
    installReinstall       = mempty,
    installAvoidReinstalls = mempty,
894
    installOverrideReinstall = mempty,
Andres Löh's avatar
Andres Löh committed
895
    installMaxBackjumps    = mempty,
896
    installUpgradeDeps     = mempty,
Andres Löh's avatar
Andres Löh committed
897
    installReorderGoals    = mempty,
898
    installIndependentGoals= mempty,
899
    installShadowPkgs      = mempty,
900
901
902
903
904
905
906
    installOnly            = mempty,
    installOnlyDeps        = mempty,
    installRootCmd         = mempty,
    installSummaryFile     = mempty,
    installLogFile         = mempty,
    installBuildReports    = mempty,
    installSymlinkBinDir   = mempty,
907
908
    installOneShot         = mempty,
    installNumJobs         = mempty
909
  }
910
  mappend a b = InstallFlags {
911
912
913
914
915
    installDocumentation   = combine installDocumentation,
    installHaddockIndex    = combine installHaddockIndex,
    installDryRun          = combine installDryRun,
    installReinstall       = combine installReinstall,
    installAvoidReinstalls = combine installAvoidReinstalls,
916
    installOverrideReinstall = combine installOverrideReinstall,
Andres Löh's avatar
Andres Löh committed
917
    installMaxBackjumps    = combine installMaxBackjumps,
918
    installUpgradeDeps     = combine installUpgradeDeps,
Andres Löh's avatar
Andres Löh committed
919
    installReorderGoals    = combine installReorderGoals,
920
    installIndependentGoals= combine installIndependentGoals,
921
    installShadowPkgs      = combine installShadowPkgs,
922
923
924
925
926
927
928
    installOnly            = combine installOnly,
    installOnlyDeps        = combine installOnlyDeps,
    installRootCmd         = combine installRootCmd,
    installSummaryFile     = combine installSummaryFile,
    installLogFile         = combine installLogFile,
    installBuildReports    = combine installBuildReports,
    installSymlinkBinDir   = combine installSymlinkBinDir,
929
930
    installOneShot         = combine installOneShot,
    installNumJobs         = combine installNumJobs
931
932
933
  }
    where combine field = field a `mappend` field b

934
935
936
937
938
939
940
941
942
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
943
  }
944
945
946
947
948
949
950
951
952
953
954
955
956
957

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 $ \_ ->
958
         "You can store your Hackage login in the ~/.cabal/config file\n",
959
960
961
962
963
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
964
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
965
966
967
968

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
969
        trueArg
970
971
972
973

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
974
975
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
976
977
978
979

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
980
981
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
      ]
  }

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

1000
-- ------------------------------------------------------------