Setup.hs 25.6 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
    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
19
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
20
    , updateCommand
ijones's avatar
ijones committed
21
    , upgradeCommand
22
    , infoCommand, InfoFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
23
    , fetchCommand
24
    , checkCommand
25
    , uploadCommand, UploadFlags(..)
26
    , reportCommand
27
    , unpackCommand, UnpackFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
28
29

    , parsePackageArgs
30
31
32
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
33
34
    ) where

35
import Distribution.Client.Types
36
         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )
37
38
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
39
40
41

import Distribution.Simple.Program
         ( defaultProgramConfiguration )
42
43
import Distribution.Simple.Command hiding (boolOpt)
import qualified Distribution.Simple.Command as Command
Duncan Coutts's avatar
Duncan Coutts committed
44
import qualified Distribution.Simple.Setup as Cabal
45
46
47
         ( configureCommand )
import Distribution.Simple.Setup
         ( ConfigFlags(..) )
48
import Distribution.Simple.Setup
Duncan Coutts's avatar
Duncan Coutts committed
49
         ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe
50
         , optionVerbosity, trueArg )
51
52
import Distribution.Simple.InstallDirs
         ( PathTemplate, toPathTemplate, fromPathTemplate )
53
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
54
         ( Version(Version), anyVersion, thisVersion )
55
import Distribution.Package
56
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
57
58
59
import Distribution.Text
         ( Text(parse), display )
import Distribution.ReadE
60
61
62
         ( readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse
         ( ReadP, readP_to_S, char, munch1, pfail, (+++) )
63
64
import Distribution.Verbosity
         ( Verbosity, normal )
65

66
67
68
69
70
71
72
73
74
75
76
77
import Data.Char
         ( isSpace, isAlphaNum )
import Data.Maybe
         ( listToMaybe, maybeToList )
import Data.Monoid
         ( Monoid(..) )
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
78

79
80
81
82
83
84
85
86
87
88
89
90
91
-- ------------------------------------------------------------
-- * 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,
    globalRemoteRepos    :: [RemoteRepo],     -- ^Available Hackage servers.
    globalCacheDir       :: Flag FilePath,
    globalLocalRepos     :: [FilePath]
  }
Duncan Coutts's avatar
Duncan Coutts committed
92

93
94
95
96
97
98
99
100
101
102
103
104
105
106
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
    globalVersion        = Flag False,
    globalNumericVersion = Flag False,
    globalConfigFile     = mempty,
    globalRemoteRepos    = [],
    globalCacheDir       = mempty,
    globalLocalRepos     = mempty
  }

globalCommand :: CommandUI GlobalFlags
globalCommand = CommandUI {
    commandName         = "",
    commandSynopsis     = "",
107
108
109
110
    commandUsage        = \_ ->
         "This program is the command line interface "
           ++ "to the Haskell Cabal infrastructure.\n"
      ++ "See http://www.haskell.org/cabal/ for more information.\n",
111
    commandDescription  = Just $ \pname ->
112
113
114
115
116
117
         "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",
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
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
    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)
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
    globalVersion        = mempty,
    globalNumericVersion = mempty,
    globalConfigFile     = mempty,
    globalRemoteRepos    = mempty,
    globalCacheDir       = mempty,
    globalLocalRepos     = mempty
  }
  mappend a b = GlobalFlags {
    globalVersion        = combine globalVersion,
    globalNumericVersion = combine globalNumericVersion,
    globalConfigFile     = combine globalConfigFile,
    globalRemoteRepos    = combine globalRemoteRepos,
    globalCacheDir       = combine globalCacheDir,
    globalLocalRepos     = combine globalLocalRepos
Duncan Coutts's avatar
Duncan Coutts committed
169
  }
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
    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
187

188
configureCommand :: CommandUI ConfigFlags
189
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
190
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
191
192
  }

193
194
195
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

196
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
197
198
199
filterConfigureFlags flags cabalLibVersion
  | cabalLibVersion >= Version [1,3,10] [] = flags
    -- older Cabal does not grok the constraints flag:
200
  | otherwise = flags { configConstraints = [] }
201

202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256

-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
    configPreferences  :: [Dependency]
  }

defaultConfigExFlags :: ConfigExFlags
defaultConfigExFlags = mempty

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
         liftOptions fst setFst (configureOptions   showOrParseArgs)
      ++ 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))

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

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
    configPreferences  = mempty
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
    configPreferences  = combine configPreferences
  }
    where combine field = field a `mappend` field b

257
258
259
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------
260

261
fetchCommand :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
262
263
264
265
266
fetchCommand = CommandUI {
    commandName         = "fetch",
    commandSynopsis     = "Downloads packages for later installation or study.",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "fetch",
267
    commandDefaultFlags = toFlag normal,
268
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
269
270
  }

271
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
272
273
274
275
276
updateCommand = CommandUI {
    commandName         = "update",
    commandSynopsis     = "Updates list of known packages",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "update",
277
    commandDefaultFlags = toFlag normal,
278
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
279
280
  }

281
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)
282
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
283
284
285
    commandName         = "upgrade",
    commandSynopsis     = "Upgrades installed packages to the latest available version",
    commandDescription  = Nothing,
286
    commandUsage        = usagePackages "upgrade",
287
    commandDefaultFlags = (mempty, mempty, mempty),
288
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
289
290
  }

Duncan Coutts's avatar
Duncan Coutts committed
291
292
293
294
295
296
297
298
299
300
301
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

302
303
304
305
306
307
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
    commandSynopsis     = "Check the package for common mistakes",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
308
    commandDefaultFlags = toFlag normal,
309
    commandOptions      = \_ -> []
310
311
312
313
314
315
316
317
318
  }

reportCommand :: CommandUI (Flag Verbosity)
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " report\n",
    commandDefaultFlags = toFlag normal,
319
    commandOptions      = \_ -> [optionVerbosity id const]
320
321
  }

322
323
324
325
326
327
328
329
330
331
332
333
334
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
-- ------------------------------------------------------------
-- * Unpack flags
-- ------------------------------------------------------------

data UnpackFlags = UnpackFlags {
      unpackDestDir :: Flag FilePath,
      unpackVerbosity :: Flag Verbosity
    }

defaultUnpackFlags :: UnpackFlags
defaultUnpackFlags = UnpackFlags {
    unpackDestDir = mempty,
    unpackVerbosity = toFlag normal
   }

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")
       ]
  }

instance Monoid UnpackFlags where
  mempty = defaultUnpackFlags
  mappend a b = UnpackFlags {
     unpackDestDir = combine unpackDestDir
    ,unpackVerbosity = combine unpackVerbosity
  }
    where combine field = field a `mappend` field b

362
363
364
365
366
367
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
368
    listSimpleOutput :: Flag Bool,
369
370
371
372
373
374
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
375
    listSimpleOutput = Flag False,
376
377
378
379
380
381
    listVerbosity = toFlag normal
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
382
    commandSynopsis     = "List packages matching a search string.",
383
384
    commandDescription  = Nothing,
    commandUsage        = usagePackages "list",
385
    commandDefaultFlags = defaultListFlags,
386
    commandOptions      = \_ -> [
387
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
388

389
        , option [] ["installed"]
390
391
392
393
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

394
395
396
397
398
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

399
400
401
402
403
404
405
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
406
    listSimpleOutput = combine listSimpleOutput,
407
408
409
410
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
-- ------------------------------------------------------------
-- * 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

443
444
445
446
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

447
448
-- | Install takes the same flags as configure along with a few extras.
--
449
data InstallFlags = InstallFlags {
450
    installDocumentation:: Flag Bool,
451
    installHaddockIndex :: Flag PathTemplate,
452
    installDryRun       :: Flag Bool,
453
    installReinstall    :: Flag Bool,
454
455
    installOnly         :: Flag Bool,
    installRootCmd      :: Flag String,
456
457
458
    installSummaryFile  :: [PathTemplate],
    installLogFile      :: Flag PathTemplate,
    installBuildReports :: Flag ReportLevel,
459
    installSymlinkBinDir:: Flag FilePath
460
461
462
463
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
464
    installDocumentation= Flag False,
465
    installHaddockIndex = Flag docIndexFile,
466
    installDryRun       = Flag False,
467
    installReinstall    = Flag False,
468
469
    installOnly         = Flag False,
    installRootCmd      = mempty,
470
    installSummaryFile  = mempty,
471
    installLogFile      = mempty,
472
    installBuildReports = Flag NoReports,
473
    installSymlinkBinDir= mempty
474
  }
475
476
  where
    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
477

478
479
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)
installCommand = CommandUI {
480
481
482
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
483
484
485
486
487
  commandDescription  = Just $ \pname ->
    let original = case commandDescription configureCommand of
          Just desc -> desc pname ++ "\n"
          Nothing   -> ""
     in original
488
     ++ "Examples:\n"
489
490
491
492
493
494
495
496
     ++ "  " ++ 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",
497
  commandDefaultFlags = (mempty, mempty, mempty),
498
  commandOptions      = \showOrParseArgs ->
499
500
501
       liftOptions get1 set1 (configureOptions   showOrParseArgs)
    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)
502
  }
503
504
505
506
  where
    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
507
508
509
510

installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
      [ option "" ["documentation"]
511
512
513
514
          "building of documentation"
          installDocumentation (\v flags -> flags { installDocumentation = v })
          (boolOpt [] [])

515
516
      , option [] ["doc-index-file"]
          "A central index of haddock API documentation (template cannot use $pkgid)"
517
518
519
          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
520

521
      , option [] ["dry-run"]
522
523
524
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
525

526
527
528
529
530
      , option [] ["reinstall"]
          "Install even if it means installing the same version again."
          installReinstall (\v flags -> flags { installReinstall = v })
          trueArg

531
532
533
534
535
      , option [] ["root-cmd"]
          "Command used to gain root privileges, when installing with --global."
          installRootCmd (\v flags -> flags { installRootCmd = v })
          (reqArg' "COMMAND" toFlag flagToList)

536
537
538
539
540
      , option [] ["symlink-bindir"]
          "Add symlinks to installed executables into this directory."
           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })
           (reqArgFlag "DIR")

541
542
543
544
545
546
      , 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
547
548
          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"
          installLogFile (\v flags -> flags { installLogFile = v })
549
550
          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
                              (flagToList . fmap fromPathTemplate))
Duncan Coutts's avatar
Duncan Coutts committed
551

552
553
      , option [] ["remote-build-reporting"]
          "Generate build reports to send to a remote server (none, anonymous or detailed)."
554
          installBuildReports (\v flags -> flags { installBuildReports = v })
555
556
557
558
          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "
                                            ++ "'anonymous' or 'detailed'")
                                      (toFlag `fmap` parse))
                          (flagToList . fmap display))
559

560
561
562
563
564
565
566
      ] ++ 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
             : []
567
          _ -> []
568
569

instance Monoid InstallFlags where
570
571
  mempty = InstallFlags {
    installDocumentation= mempty,
572
    installHaddockIndex = mempty,
573
574
575
576
    installDryRun       = mempty,
    installReinstall    = mempty,
    installOnly         = mempty,
    installRootCmd      = mempty,
577
    installSummaryFile  = mempty,
578
579
    installLogFile      = mempty,
    installBuildReports = mempty,
580
    installSymlinkBinDir= mempty
581
  }
582
  mappend a b = InstallFlags {
583
    installDocumentation= combine installDocumentation,
584
    installHaddockIndex = combine installHaddockIndex,
585
    installDryRun       = combine installDryRun,
586
    installReinstall    = combine installReinstall,
587
588
    installOnly         = combine installOnly,
    installRootCmd      = combine installRootCmd,
589
    installSummaryFile  = combine installSummaryFile,
590
    installLogFile      = combine installLogFile,
591
    installBuildReports = combine installBuildReports,
592
    installSymlinkBinDir= combine installSymlinkBinDir
593
594
595
  }
    where combine field = field a `mappend` field b

596
597
598
599
600
601
602
603
604
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
605
  }
606
607
608
609
610
611
612
613
614
615
616
617
618
619

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 $ \_ ->
620
         "You can store your Hackage login in the ~/.cabal/config file\n",
621
622
623
624
625
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
626
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
627
628
629
630

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
631
        trueArg
632
633
634
635

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
636
637
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
638
639
640
641

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
642
643
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
      ]
  }

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

-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------

666
667
668
boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt  = Command.boolOpt  flagToMaybe Flag

669
670
671
672
reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList

673
674
675
676
liftOptions :: (b -> a) -> (a -> b -> b)
            -> [OptionField a] -> [OptionField b]
liftOptions get set = map (liftOption get set)

Duncan Coutts's avatar
Duncan Coutts committed
677
usagePackages :: String -> String -> String
678
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
679
680
681
682
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

683
684
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
Duncan Coutts's avatar
Duncan Coutts committed
685
686
687
688
689
parsePackageArgs = parsePkgArgs []
  where
    parsePkgArgs ds [] = Right (reverse ds)
    parsePkgArgs ds (arg:args) =
      case readPToMaybe parseDependencyOrPackageId arg of
690
        Just dep -> parsePkgArgs (dep:ds) args
691
692
693
        Nothing  -> Left $
         show arg ++ " is not valid syntax for a package name or"
                  ++ " package dependency."
694

695
696
697
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
                                     , all isSpace s ]
698

699
700
parseDependencyOrPackageId :: Parse.ReadP r Dependency
parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse
701
702
703
  where
    pkgidToDependency :: PackageIdentifier -> Dependency
    pkgidToDependency p = case packageVersion p of
Duncan Coutts's avatar
Duncan Coutts committed
704
705
      Version [] _ -> Dependency (packageName p) anyVersion
      version      -> Dependency (packageName p) (thisVersion version)
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723

showRepo :: RemoteRepo -> String
showRepo repo = remoteRepoName repo ++ ":"
             ++ uriToString id (remoteRepoURI repo) []

readRepo :: String -> Maybe RemoteRepo
readRepo = readPToMaybe parseRepo

parseRepo :: Parse.ReadP r RemoteRepo
parseRepo = do
  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")
  Parse.char ':'
  uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")
  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)
  return $ RemoteRepo {
    remoteRepoName = name,
    remoteRepoURI  = uri
  }