Setup.hs 56.3 KB
Newer Older
1 2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.Setup
4 5 6 7 8 9 10 11 12
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
13
module Distribution.Client.Setup
14
    ( globalCommand, GlobalFlags(..), globalRepos
15
    , configureCommand, ConfigFlags(..), filterConfigureFlags
16 17
    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
                        , configureExOptions
ttuegel's avatar
ttuegel committed
18
    , buildCommand, BuildFlags(..)
19
    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
20
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
21
    , updateCommand
ijones's avatar
ijones committed
22
    , upgradeCommand
23
    , infoCommand, InfoFlags(..)
24
    , fetchCommand, FetchFlags(..)
25
    , checkCommand
26
    , uploadCommand, UploadFlags(..)
27
    , reportCommand, ReportFlags(..)
28
    , unpackCommand, UnpackFlags(..)
29
    , initCommand, IT.InitFlags(..)
30
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
31
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
32
    , indexCommand, IndexFlags(..)
refold's avatar
refold committed
33 34 35 36
    , dumpPkgEnvCommand
    , sandboxInitCommand, sandboxConfigureCommand, sandboxAddSourceCommand
    , sandboxBuildCommand, sandboxInstallCommand
    , SandboxFlags(..), defaultSandboxLocation
Duncan Coutts's avatar
Duncan Coutts committed
37 38

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

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

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

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

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

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

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

globalCommand :: CommandUI GlobalFlags
globalCommand = CommandUI {
    commandName         = "",
    commandSynopsis     = "",
130 131 132 133
    commandUsage        = \_ ->
         "This program is the command line interface "
           ++ "to the Haskell Cabal infrastructure.\n"
      ++ "See http://www.haskell.org/cabal/ for more information.\n",
134
    commandDescription  = Just $ \pname ->
135 136 137 138 139 140
         "For more information about a command use:\n"
      ++ "  " ++ pname ++ " COMMAND --help\n\n"
      ++ "To install Cabal packages from hackage use:\n"
      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
    commandDefaultFlags = defaultGlobalFlags,
    commandOptions      = \showOrParseArgs ->
      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)
      [option ['V'] ["version"]
         "Print version information"
         globalVersion (\v flags -> flags { globalVersion = v })
         trueArg

      ,option [] ["numeric-version"]
         "Print just the version number"
         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })
         trueArg

      ,option [] ["config-file"]
         "Set an alternate location for the config file"
         globalConfigFile (\v flags -> flags { globalConfigFile = v })
         (reqArgFlag "FILE")

      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
         (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo))

      ,option [] ["remote-repo-cache"]
         "The location where downloads from all remote repos are cached"
         globalCacheDir (\v flags -> flags { globalCacheDir = v })
         (reqArgFlag "DIR")

      ,option [] ["local-repo"]
         "The location of a local repository"
         globalLocalRepos (\v flags -> flags { globalLocalRepos = v })
         (reqArg' "DIR" (\x -> [x]) id)
173

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

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

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

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

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

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

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

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

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

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

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

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
259 260
         liftOptions fst setFst (filter ((/="constraint") . optionName) $
                                 configureOptions   showOrParseArgs)
261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs =
  [ option [] ["cabal-lib-version"]
      ("Select which version of the Cabal lib to use to build packages "
      ++ "(useful for testing).")
      configCabalVersion (\v flags -> flags { configCabalVersion = v })
      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
                                    (fmap toFlag parse))
                        (map display . flagToList))
276 277 278 279 280 281
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
              (fmap (\x -> [x]) (ReadE readUserConstraint))
              (map display))
282 283 284 285

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

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

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

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

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

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

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

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

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
348 349
fetchCommand = CommandUI {
    commandName         = "fetch",
350
    commandSynopsis     = "Downloads packages for later installation.",
Duncan Coutts's avatar
Duncan Coutts committed
351 352
    commandDescription  = Nothing,
    commandUsage        = usagePackages "fetch",
353
    commandDefaultFlags = defaultFetchFlags,
354
    commandOptions      = \ showOrParseArgs -> [
355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
         optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })

--     , option "o" ["output"]
--         "Put the package(s) somewhere specific rather than the usual cache."
--         fetchOutput (\v flags -> flags { fetchOutput = v })
--         (reqArgFlag "PATH")

       , option [] ["dependencies", "deps"]
           "Resolve and fetch dependencies (default)"
           fetchDeps (\v flags -> flags { fetchDeps = v })
           trueArg

       , option [] ["no-dependencies", "no-deps"]
           "Ignore dependencies"
           fetchDeps (\v flags -> flags { fetchDeps = v })
           falseArg

       , option [] ["dry-run"]
           "Do not install anything, only print what would be installed."
           fetchDryRun (\v flags -> flags { fetchDryRun = v })
           trueArg
376 377 378 379

       ] ++

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

Duncan Coutts's avatar
Duncan Coutts committed
386 387
  }

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

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

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

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

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

433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450
-- ------------------------------------------------------------
-- * Report flags
-- ------------------------------------------------------------

data ReportFlags = ReportFlags {
    reportUsername  :: Flag Username,
    reportPassword  :: Flag Password,
    reportVerbosity :: Flag Verbosity
  }

defaultReportFlags :: ReportFlags
defaultReportFlags = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = toFlag normal
  }

reportCommand :: CommandUI ReportFlags
451 452 453
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473
    commandDescription  = Just $ \_ ->
         "You can store your Hackage login in the ~/.cabal/config file\n",
    commandUsage        = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultReportFlags,
    commandOptions      = \_ ->
      [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })

      ,option ['u'] ["username"]
        "Hackage username."
        reportUsername (\v flags -> flags { reportUsername = v })
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))

      ,option ['p'] ["password"]
        "Hackage password."
        reportPassword (\v flags -> flags { reportPassword = v })
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
      ]
474 475
  }

476 477 478 479 480 481 482 483 484 485 486 487 488
instance Monoid ReportFlags where
  mempty = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = mempty
  }
  mappend a b = ReportFlags {
    reportUsername  = combine reportUsername,
    reportPassword  = combine reportPassword,
    reportVerbosity = combine reportVerbosity
  }
    where combine field = field a `mappend` field b

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

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

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

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

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

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

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

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

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

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

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

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

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

575 576 577 578 579 580 581
        ]
  }

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

587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618
-- ------------------------------------------------------------
-- * Info flags
-- ------------------------------------------------------------

data InfoFlags = InfoFlags {
    infoVerbosity :: Flag Verbosity
  }

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

infoCommand  :: CommandUI InfoFlags
infoCommand = CommandUI {
    commandName         = "info",
    commandSynopsis     = "Display detailed information about a particular package.",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "info",
    commandDefaultFlags = defaultInfoFlags,
    commandOptions      = \_ -> [
        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })
        ]
  }

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

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

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

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

674 675 676
defaultMaxBackjumps :: Int
defaultMaxBackjumps = 200

677 678
defaultSolver :: PreSolver
defaultSolver = Choose
679 680

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

683
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
684
installCommand = CommandUI {
685 686 687
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
688 689 690 691 692
  commandDescription  = Just $ \pname ->
    let original = case commandDescription configureCommand of
          Just desc -> desc pname ++ "\n"
          Nothing   -> ""
     in original
693
     ++ "Examples:\n"
694 695 696 697 698 699 700 701
     ++ "  " ++ pname ++ " install                 "
     ++ "    Package in the current directory\n"
     ++ "  " ++ pname ++ " install foo             "
     ++ "    Package from the hackage server\n"
     ++ "  " ++ pname ++ " install foo-1.0         "
     ++ "    Specific version of a package\n"
     ++ "  " ++ pname ++ " install 'foo < 2'       "
     ++ "    Constrained package version\n",
702
  commandDefaultFlags = (mempty, mempty, mempty, mempty),
703
  commandOptions      = \showOrParseArgs ->
704 705
       liftOptions get1 set1 (filter ((/="constraint") . optionName) $
                              configureOptions   showOrParseArgs)
706 707
    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)
708
    ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)
709
  }
710
  where
711 712 713 714 715
    get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d)
    get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d)
    get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)
    get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d)

716 717 718 719 720 721 722 723 724 725 726 727 728
haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]
haddockOptions showOrParseArgs
  = [ opt { optionName = "haddock-" ++ name,
            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr
                          | descr <- optionDescr opt] }
    | opt <- commandOptions Cabal.haddockCommand showOrParseArgs
    , let name = optionName opt
    , name `elem` ["hoogle", "html", "html-location",
                   "executables", "internal", "css",
                   "hyperlink-source", "hscolour-css",
                   "contents-location"]
    ]
  where
729 730 731 732 733
    fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a
    fmapOptFlags modify (ReqArg d f p r w)    = ReqArg d (modify f) p r w
    fmapOptFlags modify (OptArg d f p r i w)  = OptArg d (modify f) p r i w
    fmapOptFlags modify (ChoiceOpt xs)        = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]
    fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w
734 735 736 737

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

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

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

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

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

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

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

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

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

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

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

795 796 797 798 799 800
      , option [] ["build-summary"]
          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"
          installSummaryFile (\v flags -> flags { installSummaryFile = v })
          (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

emptyInitFlags :: IT.InitFlags
emptyInitFlags  = mempty

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

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

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

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

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

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

1002
      , option [] ["package-dir"]
1003 1004 1005 1006
        "Root directory of the package (default = current directory)."
        IT.packageDir (\v flags -> flags { IT.packageDir = v })
        (reqArgFlag "DIRECTORY")

1007
      , option ['p'] ["package-name"]
1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018
        "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))

1019
      , option [] ["cabal-version"]
1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043