Setup.hs 31.4 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(..)
28
    , initCommand, IT.InitFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
29
30

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

36
import Distribution.Client.Types
37
         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )
38
39
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
40
41
import qualified Distribution.Client.Init.Types as IT
         ( InitFlags(..), PackageType(..) )
42
43
44

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

71
72
73
import Data.Char
         ( isSpace, isAlphaNum )
import Data.Maybe
74
         ( listToMaybe, maybeToList, fromMaybe )
75
76
77
78
79
80
81
82
import Data.Monoid
         ( Monoid(..) )
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
83

84
85
86
87
88
89
90
91
92
93
94
95
96
-- ------------------------------------------------------------
-- * 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
97

98
99
100
101
102
103
104
105
106
107
108
109
110
111
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
    globalVersion        = Flag False,
    globalNumericVersion = Flag False,
    globalConfigFile     = mempty,
    globalRemoteRepos    = [],
    globalCacheDir       = mempty,
    globalLocalRepos     = mempty
  }

globalCommand :: CommandUI GlobalFlags
globalCommand = CommandUI {
    commandName         = "",
    commandSynopsis     = "",
112
113
114
115
    commandUsage        = \_ ->
         "This program is the command line interface "
           ++ "to the Haskell Cabal infrastructure.\n"
      ++ "See http://www.haskell.org/cabal/ for more information.\n",
116
    commandDescription  = Just $ \pname ->
117
118
119
120
121
122
         "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",
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
169
170
171
172
173
    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
174
  }
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
    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
192

193
configureCommand :: CommandUI ConfigFlags
194
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
195
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
196
197
  }

198
199
200
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

201
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
202
203
204
filterConfigureFlags flags cabalLibVersion
  | cabalLibVersion >= Version [1,3,10] [] = flags
    -- older Cabal does not grok the constraints flag:
205
  | otherwise = flags { configConstraints = [] }
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
257
258
259
260
261

-- ------------------------------------------------------------
-- * 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

262
263
264
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------
265

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

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

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

Duncan Coutts's avatar
Duncan Coutts committed
296
297
298
299
300
301
302
303
304
305
306
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

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

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,
324
    commandOptions      = \_ -> [optionVerbosity id const]
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
362
363
364
365
366
-- ------------------------------------------------------------
-- * 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

367
368
369
370
371
372
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
373
    listSimpleOutput :: Flag Bool,
374
375
376
377
378
379
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
380
    listSimpleOutput = Flag False,
381
382
383
384
385
386
    listVerbosity = toFlag normal
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
387
    commandSynopsis     = "List packages matching a search string.",
388
389
    commandDescription  = Nothing,
    commandUsage        = usagePackages "list",
390
    commandDefaultFlags = defaultListFlags,
391
    commandOptions      = \_ -> [
392
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
393

394
        , option [] ["installed"]
395
396
397
398
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

399
400
401
402
403
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

404
405
406
407
408
409
410
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
411
    listSimpleOutput = combine listSimpleOutput,
412
413
414
415
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

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
443
444
445
446
447
-- ------------------------------------------------------------
-- * 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

448
449
450
451
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

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

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

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

installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
      [ option "" ["documentation"]
516
517
518
519
          "building of documentation"
          installDocumentation (\v flags -> flags { installDocumentation = v })
          (boolOpt [] [])

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

526
      , option [] ["dry-run"]
527
528
529
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
530

531
532
533
534
535
      , option [] ["reinstall"]
          "Install even if it means installing the same version again."
          installReinstall (\v flags -> flags { installReinstall = v })
          trueArg

536
537
538
539
540
      , option [] ["root-cmd"]
          "Command used to gain root privileges, when installing with --global."
          installRootCmd (\v flags -> flags { installRootCmd = v })
          (reqArg' "COMMAND" toFlag flagToList)

541
542
543
544
545
      , option [] ["symlink-bindir"]
          "Add symlinks to installed executables into this directory."
           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })
           (reqArgFlag "DIR")

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

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

565
566
567
568
569
570
571
      ] ++ 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
             : []
572
          _ -> []
573
574

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

601
602
603
604
605
606
607
608
609
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
610
  }
611
612
613
614
615
616
617
618
619
620
621
622
623
624

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

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
636
        trueArg
637
638
639
640

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
641
642
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
643
644
645
646

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

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

667
668
669
670
671
672
673
674
675
676
677
678
679
680
-- ------------------------------------------------------------
-- * Init flags
-- ------------------------------------------------------------

emptyInitFlags :: IT.InitFlags
emptyInitFlags  = mempty

defaultInitFlags :: IT.InitFlags
defaultInitFlags  = emptyInitFlags

initCommand :: CommandUI IT.InitFlags
initCommand = CommandUI {
    commandName = "init",
    commandSynopsis = "Interactively create a .cabal file.",
681
682
683
684
685
686
687
688
689
690
691
692
    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:",
693
694
    commandDefaultFlags = defaultInitFlags,
    commandOptions = \_ ->
695
      [ option ['n'] ["non-interactive"]
696
697
698
699
700
701
702
703
704
        "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

705
      , option [] ["no-comments"]
706
707
708
709
710
        "Do not generate explanatory comments in the .cabal file."
        IT.noComments (\v flags -> flags { IT.noComments = v })
        trueArg

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

715
      , option [] ["package-dir"]
716
717
718
719
        "Root directory of the package (default = current directory)."
        IT.packageDir (\v flags -> flags { IT.packageDir = v })
        (reqArgFlag "DIRECTORY")

720
      , option ['p'] ["package-name"]
721
722
723
724
725
726
727
728
729
730
731
        "Name of the Cabal package to create."
        IT.packageName (\v flags -> flags { IT.packageName = v })
        (reqArgFlag "PACKAGE")

      , option [] ["version"]
        "Initial version of the package."
        IT.version (\v flags -> flags { IT.version = v })
        (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++)
                                      (toFlag `fmap` parse))
                          (flagToList . fmap display))

732
      , option [] ["cabal-version"]
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
        "Required version of the Cabal library."
        IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })
        (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++)
                                            (toFlag `fmap` parse))
                                (flagToList . fmap display))

      , option ['l'] ["license"]
        "Project license."
        IT.license (\v flags -> flags { IT.license = v })
        (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++)
                                      (toFlag `fmap` parse))
                          (flagToList . fmap display))

      , option ['a'] ["author"]
        "Name of the project's author."
        IT.author (\v flags -> flags { IT.author = v })
        (reqArgFlag "NAME")

      , option ['e'] ["email"]
        "Email address of the maintainer."
        IT.email (\v flags -> flags { IT.email = v })
        (reqArgFlag "EMAIL")

      , option ['u'] ["homepage"]
        "Project homepage and/or repository."
        IT.homepage (\v flags -> flags { IT.homepage = v })
        (reqArgFlag "URL")

      , option ['s'] ["synopsis"]
        "Short project synopsis."
        IT.synopsis (\v flags -> flags { IT.synopsis = v })
        (reqArgFlag "TEXT")

      , option ['c'] ["category"]
        "Project category."
        IT.category (\v flags -> flags { IT.category = v })
        (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))
                            (flagToList . fmap (either id show)))

772
      , option [] ["is-library"]
773
774
775
776
        "Build a library."
        IT.packageType (\v flags -> flags { IT.packageType = v })
        (noArg (Flag IT.Library))

777
      , option [] ["is-executable"]
778
779
780
781
782
        "Build an executable."
        IT.packageType
        (\v flags -> flags { IT.packageType = v })
        (noArg (Flag IT.Executable))

783
      , option ['o'] ["expose-module"]
784
785
786
787
788
789
790
791
792
793
794
795
796
797
        "Export a module from the package."
        IT.exposedModules
        (\v flags -> flags { IT.exposedModules = v })
        (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++)
                                     ((Just . (:[])) `fmap` parse))
                         (fromMaybe [] . fmap (fmap display)))

      , option ['d'] ["dependency"]
        "Package dependency."
        IT.dependencies (\v flags -> flags { IT.dependencies = v })
        (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++)
                                      ((Just . (:[])) `fmap` parse))
                          (fromMaybe [] . fmap (fmap display)))

798
      , option [] ["source-dir"]
799
800
801
802
803
        "Directory containing package source."
        IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })
        (reqArg' "DIR" (Just . (:[]))
                       (fromMaybe []))

804
      , option [] ["build-tool"]
805
806
807
808
809
810
811
812
        "Required external build tool."
        IT.buildTools (\v flags -> flags { IT.buildTools = v })
        (reqArg' "TOOL" (Just . (:[]))
                        (fromMaybe []))
      ]
  }
  where readMaybe s = case reads s of
                        [(x,"")]  -> Just x
813
                        _         -> Nothing
814

815
816
817
818
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------

819
820
821
boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt  = Command.boolOpt  flagToMaybe Flag

822
823
824
825
reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList

826
827
828
829
liftOptions :: (b -> a) -> (a -> b -> b)
            -> [OptionField a] -> [OptionField b]
liftOptions get set = map (liftOption get set)

Duncan Coutts's avatar
Duncan Coutts committed
830
usagePackages :: String -> String -> String
831
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
832
833
834
835
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

836
837
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
Duncan Coutts's avatar
Duncan Coutts committed
838
839
840
841
842
parsePackageArgs = parsePkgArgs []
  where
    parsePkgArgs ds [] = Right (reverse ds)
    parsePkgArgs ds (arg:args) =
      case readPToMaybe parseDependencyOrPackageId arg of
843
        Just dep -> parsePkgArgs (dep:ds) args
844
845
846
        Nothing  -> Left $
         show arg ++ " is not valid syntax for a package name or"
                  ++ " package dependency."
847

848
849
850
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
                                     , all isSpace s ]
851

852
853
parseDependencyOrPackageId :: Parse.ReadP r Dependency
parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse
854
855
856
  where
    pkgidToDependency :: PackageIdentifier -> Dependency
    pkgidToDependency p = case packageVersion p of
Duncan Coutts's avatar
Duncan Coutts committed
857
858
      Version [] _ -> Dependency (packageName p) anyVersion
      version      -> Dependency (packageName p) (thisVersion version)
859
860
861
862
863
864
865
866
867
868
869

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` "_-.")
870
  _ <- Parse.char ':'
871
872
873
874
875
876
  uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")
  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)
  return $ RemoteRepo {
    remoteRepoName = name,
    remoteRepoURI  = uri
  }