Setup.hs 82.8 KB
Newer Older
1 2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.Setup
4 5 6 7 8 9 10 11 12
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
13
module Distribution.Client.Setup
14
    ( globalCommand, GlobalFlags(..), defaultGlobalFlags, globalRepos
15
    , configureCommand, ConfigFlags(..), filterConfigureFlags
16 17
    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
                        , configureExOptions
18
    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
19
    , replCommand, testCommand, benchmarkCommand
20
    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
21
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
22
    , updateCommand
ijones's avatar
ijones committed
23
    , upgradeCommand
24
    , infoCommand, InfoFlags(..)
25
    , fetchCommand, FetchFlags(..)
26
    , freezeCommand, FreezeFlags(..)
27
    , getCommand, unpackCommand, GetFlags(..)
28
    , checkCommand
29
    , formatCommand
30
    , uploadCommand, UploadFlags(..)
31
    , reportCommand, ReportFlags(..)
refold's avatar
refold committed
32
    , runCommand
33
    , initCommand, IT.InitFlags(..)
34
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
35
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
refold's avatar
refold committed
36
    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
37
    , execCommand, ExecFlags(..)
38
    , userConfigCommand, UserConfigFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
39 40

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

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

59
import Distribution.Simple.Compiler (PackageDB)
60 61
import Distribution.Simple.Program
         ( defaultProgramConfiguration )
62 63
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
Duncan Coutts's avatar
Duncan Coutts committed
64
import qualified Distribution.Simple.Setup as Cabal
65
import Distribution.Simple.Setup
66 67
         ( ConfigFlags(..), BuildFlags(..), ReplFlags
         , TestFlags(..), BenchmarkFlags(..)
68
         , SDistFlags(..), HaddockFlags(..)
69
         , readPackageDbList, showPackageDbList
70
         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
71
         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs )
72
import Distribution.Simple.InstallDirs
73 74
         ( PathTemplate, InstallDirs(sysconfdir)
         , toPathTemplate, fromPathTemplate )
75
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
76
         ( Version(Version), anyVersion, thisVersion )
77
import Distribution.Package
78
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
79 80
import Distribution.PackageDescription
         ( RepoKind(..) )
81
import Distribution.Text
82
         ( Text(..), display )
83
import Distribution.ReadE
84
         ( ReadE(..), readP_to_E, succeedReadE )
85
import qualified Distribution.Compat.ReadP as Parse
86
         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )
87 88
import Distribution.Verbosity
         ( Verbosity, normal )
89
import Distribution.Simple.Utils
90
         ( wrapText, wrapLine )
91

92 93
import Data.Char
         ( isSpace, isAlphaNum )
94
import Data.List
95
         ( intercalate, deleteFirstsBy )
96
import Data.Maybe
97
         ( listToMaybe, maybeToList, fromMaybe )
98 99 100 101 102 103 104 105
import Data.Monoid
         ( Monoid(..) )
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
106

107 108 109 110 111 112
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
113 114 115 116
    globalVersion           :: Flag Bool,
    globalNumericVersion    :: Flag Bool,
    globalConfigFile        :: Flag FilePath,
    globalSandboxConfigFile :: Flag FilePath,
117
    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
118
    globalCacheDir          :: Flag FilePath,
119
    globalLocalRepos        :: NubList FilePath,
120
    globalLogsDir           :: Flag FilePath,
121
    globalWorldFile         :: Flag FilePath,
122 123
    globalRequireSandbox    :: Flag Bool,
    globalIgnoreSandbox     :: Flag Bool
124
  }
Duncan Coutts's avatar
Duncan Coutts committed
125

126 127
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
128 129 130 131
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
132
    globalRemoteRepos       = mempty,
133 134 135
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
136
    globalWorldFile         = mempty,
137 138
    globalRequireSandbox    = Flag False,
    globalIgnoreSandbox     = Flag False
139 140
  }

141 142
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
143
    commandName         = "",
144 145
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
146 147 148 149
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
150
    commandDescription  = Just $ \pname ->
151 152 153
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
        -- if new commands are added, we want them to appear even if they
        -- are not included in the custom listing below. Thus, we calculate
        -- the `otherCmds` list and append it under the `other` category.
        -- Alternatively, a new testcase could be added that ensures that
        -- the set of commands listed here is equal to the set of commands
        -- that are actually available.
        otherCmds = deleteFirstsBy (==) (map fst cmdDescs)
          [ "help"
          , "update"
          , "install"
          , "fetch"
          , "list"
          , "info"
          , "user-config"
          , "get"
          , "init"
          , "configure"
          , "build"
          , "clean"
          , "run"
          , "repl"
          , "test"
          , "bench"
          , "check"
          , "sdist"
          , "upload"
          , "report"
          , "freeze"
          , "haddock"
          , "hscolour"
          , "copy"
          , "register"
          , "sandbox"
          , "exec"
          ]
189 190
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
191 192 193 194 195 196 197 198 199
        startGroup n = " ["++n++"]"
        par          = ""
        addCmd n     = case lookup n cmdDescs of
                         Nothing -> ""
                         Just d -> "  " ++ align n ++ "    " ++ d
        addCmdCustom n d = case lookup n cmdDescs of -- make sure that the
                                                  -- command still exists.
                         Nothing -> ""
                         Just _ -> "  " ++ align n ++ "    " ++ d
200 201
      in
         "Commands:\n"
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
      ++ unlines (
        [ startGroup "global"
        , addCmd "update"
        , addCmd "install"
        , par
        , addCmd "help"
        , addCmd "info"
        , addCmd "list"
        , addCmd "fetch"
        , addCmd "user-config"
        , par
        , startGroup "package"
        , addCmd "get"
        , addCmd "init"
        , par
        , addCmd "configure"
        , addCmd "build"
        , addCmd "clean"
        , par
        , addCmd "run"
        , addCmd "repl"
        , addCmd "test"
        , addCmd "bench"
        , par
        , addCmd "check"
        , addCmd "sdist"
        , addCmd "upload"
        , addCmd "report"
        , par
        , addCmd "freeze"
        , addCmd "haddock"
        , addCmd "hscolour"
        , addCmd "copy"
        , addCmd "register"
        , par
        , startGroup "sandbox"
238
        , addCmd "sandbox"
239 240 241 242 243
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
244 245
      ++ "\n"
      ++ "For more information about a command use:\n"
246 247
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
248
      ++ "\n"
249
      ++ "To install Cabal packages from hackage use:\n"
250 251
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
252 253
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
254
    commandNotes = Nothing,
255
    commandDefaultFlags = mempty,
256
    commandOptions      = \showOrParseArgs ->
257
      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
      [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")

273 274 275 276 277 278
      ,option [] ["sandbox-config-file"]
         "Set an alternate location for the sandbox config file \
         \(default: './cabal.sandbox.config')"
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

279
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
280
         "requiring the presence of a sandbox for sandbox-aware commands"
281 282 283
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

284 285 286 287 288
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

289 290 291
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
292
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
293 294 295 296 297 298 299 300 301

      ,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 })
302
         (reqArg' "DIR" (\x -> toNubList [x]) fromNubList)
303

304 305 306 307 308
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

309 310 311 312
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
313 314 315 316 317
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
318 319 320 321 322 323 324 325
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
326
    globalWorldFile         = mempty,
327 328
    globalRequireSandbox    = mempty,
    globalIgnoreSandbox     = mempty
329 330
  }
  mappend a b = GlobalFlags {
331 332 333 334 335 336 337 338
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
339
    globalWorldFile         = combine globalWorldFile,
340 341
    globalRequireSandbox    = combine globalRequireSandbox,
    globalIgnoreSandbox     = combine globalIgnoreSandbox
Duncan Coutts's avatar
Duncan Coutts committed
342
  }
343 344 345 346 347 348 349
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
350
      | remote <- fromNubList $ globalRemoteRepos globalFlags
351 352 353 354
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
355
      | local <- fromNubList $ globalLocalRepos globalFlags ]
356 357 358 359

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

361
configureCommand :: CommandUI ConfigFlags
362
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
363
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
364 365
  }

366 367 368
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

369
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
370
filterConfigureFlags flags cabalLibVersion
371
  | cabalLibVersion >= Version [1,19,2] [] = flags_latest
372 373 374
  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10
  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0
  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0
375
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
376
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
377
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
378
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
379
  | otherwise = flags_latest
380
  where
381
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
382 383
    flags_latest = flags        { configConstraints = [] }

384
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
385 386 387 388 389 390 391
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
      flags_latest { configRelocatable = NoFlag
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
392 393
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
394
                   }
395
    -- Cabal < 1.19.2 doesn't know about '--exact-configuration'.
396
    flags_1_19_1 = flags_1_20_0 { configExactConfiguration = NoFlag }
397 398 399
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
400
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
401
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
402 403
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
404
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
405
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
406
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
407
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
408
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
409
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
410

411 412 413 414 415 416 417 418
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
419
    configExConstraints:: [UserConstraint],
420
    configPreferences  :: [Dependency],
421 422
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
423 424 425
  }

defaultConfigExFlags :: ConfigExFlags
426 427
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
428 429 430 431 432

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
433
         liftOptions fst setFst
434
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
435
                  . optionName) $ configureOptions  showOrParseArgs)
436 437 438 439 440 441 442 443 444 445 446 447 448 449 450
      ++ 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))
451 452 453 454 455 456
  , 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))
457 458 459 460

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

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
467 468

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
469
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
470
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
471
    (optArg allowNewerArgument
472 473 474
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

475
  ]
cheecheeo's avatar
cheecheeo committed
476
  where allowNewerArgument = "DEPS"
477 478 479 480

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
481
    configExConstraints= mempty,
482
    configPreferences  = mempty,
483 484
    configSolver       = mempty,
    configAllowNewer   = mempty
485 486 487
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
488
    configExConstraints= combine configExConstraints,
489
    configPreferences  = combine configPreferences,
490 491
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
492 493 494
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
495 496 497 498
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

499 500 501 502 503 504 505 506 507 508
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
509
  option [] ["only"]
510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540
  "Don't reinstall add-source dependencies (sandbox-only)"
  buildOnly (\v flags -> flags { buildOnly = v })
  (noArg (Flag SkipAddSourceDepsCheck))

  : []

buildCommand :: CommandUI (BuildFlags, BuildExFlags)
buildCommand = parent {
    commandDefaultFlags = (commandDefaultFlags parent, mempty),
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
                          (commandOptions parent showOrParseArgs)
                          ++
                          liftOptions snd setSnd (buildExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

    parent = Cabal.buildCommand defaultProgramConfiguration

instance Monoid BuildExFlags where
  mempty = BuildExFlags {
    buildOnly    = mempty
  }
  mappend a b = BuildExFlags {
    buildOnly    = combine buildOnly
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558
-- * Repl command
-- ------------------------------------------------------------

replCommand :: CommandUI (ReplFlags, BuildExFlags)
replCommand = parent {
    commandDefaultFlags = (commandDefaultFlags parent, mempty),
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
                          (commandOptions parent showOrParseArgs)
                          ++
                          liftOptions snd setSnd (buildExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

    parent = Cabal.replCommand defaultProgramConfiguration

559 560 561 562
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

563
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
564
testCommand = parent {
565 566
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
567
  commandOptions      =
568
    \showOrParseArgs -> liftOptions get1 set1
569 570
                        (commandOptions parent showOrParseArgs)
                        ++
571 572 573 574
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
575 576
  }
  where
577 578 579
    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)
580

581 582
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
583 584 585 586 587

-- ------------------------------------------------------------
-- * Bench command
-- ------------------------------------------------------------

588
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
589
benchmarkCommand = parent {
590 591
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
592
  commandOptions      =
593
    \showOrParseArgs -> liftOptions get1 set1
594 595
                        (commandOptions parent showOrParseArgs)
                        ++
596 597 598 599
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
600
  }
601
  where
602 603 604
    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)
605

606 607
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
608

609
-- ------------------------------------------------------------
610
-- * Fetch command
611
-- ------------------------------------------------------------
612

613 614 615 616
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
617
      fetchSolver           :: Flag PreSolver,
618 619 620
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
621
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
622
      fetchStrongFlags      :: Flag Bool,
623 624 625 626 627 628 629 630
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
631 632
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
633
    fetchReorderGoals     = Flag False,
634
    fetchIndependentGoals = Flag False,
635
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
636
    fetchStrongFlags      = Flag False,
637 638 639 640
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
641 642
fetchCommand = CommandUI {
    commandName         = "fetch",
643
    commandSynopsis     = "Downloads packages for later installation.",
644 645 646 647 648
    commandUsage        = usageAlternatives "fetch" [ "[FLAGS] PACKAGES"
                                                    ],
    commandDescription  = Just $ \_ ->
          "Note that it currently is not possible to fetch the dependencies for a\n"
       ++ "package in the current directory.\n",
649
    commandNotes        = Nothing,
650
    commandDefaultFlags = defaultFetchFlags,
651
    commandOptions      = \ showOrParseArgs -> [
652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672
         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
673 674 675 676

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
677 678
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
679 680
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
681
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
682
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
683

Duncan Coutts's avatar
Duncan Coutts committed
684 685
  }

686 687 688 689 690 691
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
692 693
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
694 695 696 697 698
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
699
      freezeStrongFlags      :: Flag Bool,
700 701 702 703 704 705
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
706 707
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
708 709
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
710
    freezeReorderGoals     = Flag False,
711 712
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
713
    freezeStrongFlags      = Flag False,
714 715 716 717 718 719 720
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
721 722 723 724 725 726 727 728
    commandDescription  = Just $ \_ -> wrapText $
         "Calculates a valid set of dependencies and their exact versions. "
      ++ "If successful, saves the result to the file `cabal.config`.\n"
      ++ "\n"
      ++ "The package versions specified in `cabal.config` will be used for "
      ++ "any future installs.\n"
      ++ "\n"
      ++ "An existing `cabal.config` is ignored and overwritten.\n",
729
    commandNotes        = Nothing,
730 731 732
    commandUsage        = usageAlternatives "freeze" [""
                                                     ,"PACKAGES"
                                                     ],
733 734 735 736 737 738 739 740 741
    commandDefaultFlags = defaultFreezeFlags,
    commandOptions      = \ showOrParseArgs -> [
         optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })

       , option [] ["dry-run"]
           "Do not freeze anything, only print what would be frozen"
           freezeDryRun (\v flags -> flags { freezeDryRun = v })
           trueArg

742 743 744 745 746 747 748 749 750 751
       , option [] ["tests"]
           "freezing of the dependencies of any tests suites in the package description file."
           freezeTests (\v flags -> flags { freezeTests = v })
           (boolOpt [] [])

       , option [] ["benchmarks"]
           "freezing of the dependencies of any benchmarks suites in the package description file."
           freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v })
           (boolOpt [] [])

752 753 754 755 756 757 758 759
       ] ++

       optionSolver      freezeSolver           (\v flags -> flags { freezeSolver           = v }) :
       optionSolverFlags showOrParseArgs
                         freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })
                         freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })
                         freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
                         freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
760
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
761 762 763

  }

764 765 766 767
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

768
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
769 770
updateCommand = CommandUI {
    commandName         = "update",
771
    commandSynopsis     = "Updates list of known packages.",
772 773 774
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
775 776 777
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
778
    commandUsage        = usageFlags "update",
779
    commandDefaultFlags = toFlag normal,
780
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
781 782
  }

783
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
784
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
785
    commandName         = "upgrade",
786
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
787
    commandDescription  = Nothing,
refold's avatar
refold committed
788
    commandUsage        = usageFlagsOrPackages "upgrade",
789
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
790
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
791 792
  }

Duncan Coutts's avatar
Duncan Coutts committed
793 794 795 796 797 798 799 800 801 802 803
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

804 805 806
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
807
    commandSynopsis     = "Check the package for common mistakes.",
808 809 810 811 812 813
    commandDescription  = Just $ \_ -> wrapText $
         "Expects a .cabal package file in the current directory.\n"
      ++ "\n"
      ++ "The checks correspond to the requirements to packages on Hackage. "
      ++ "If no errors and warnings are reported, Hackage will accept this "
      ++ "package.\n",
814
    commandNotes        = Nothing,
815
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
816
    commandDefaultFlags = toFlag normal,
817
    commandOptions      = \_ -> []
818 819
  }

820 821 822 823 824
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
825
    commandNotes        = Nothing,
826
    commandUsage        = usageAlternatives "format" ["[FILE]"],
827 828 829 830
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

831
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
832 833
runCommand = CommandUI {
    commandName         = "run",
834 835 836 837 838
    commandSynopsis     = "Builds and runs an executable.",
    commandDescription  = Just $ \_ -> wrapText $
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
      ++ "is built and executed.\n",
839
    commandNotes        = Nothing,
840 841
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
842
    commandDefaultFlags = mempty,
843 844
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
845
                          (commandOptions parent showOrParseArgs)
846 847 848
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
849 850
  }
  where
851 852 853
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

854
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
855

856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873
-- ------------------------------------------------------------
-- * 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
874 875 876
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
877 878
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
879
         "You can store your Hackage login in the ~/.cabal/config file\n",
880
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896
    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))
      ]
897 898
  }

899 900 901 902 903 904 905 906 907 908 909 910 911
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

912
-- ------------------------------------------------------------
913
-- * Get flags
914 915
-- ------------------------------------------------------------

916 917 918 919 920 921
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
922

923 924 925 926 927 928
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
929 930
   }

931 932 933
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
934 935
    commandSynopsis     = "Download/Extract a package's source code (repository).",
    commandDescription  = Just $ \_ -> wrapText $
936 937 938 939
          "Creates a local copy of a package's source code. By default it gets "
       ++ "the source\ntarball and unpacks it in a local subdirectory. "
       ++ "Alternatively, with -s it will\nget the code from the source "
       ++ "repository specified by the package.\n",
940
    commandNotes        = Nothing,
941
    commandUsage        = usagePackages "get",
942
    commandDefaultFlags = defaultGetFlags,
943
    commandOptions      = \_ -> [
944
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
945 946

       ,option "d" ["destdir"]
refold's avatar
refold committed
947
         "Where to place the package source, defaults to the current directory."
948
         getDestDir (\v flags -> flags { getDestDir = v })
949
         (reqArgFlag "PATH")
950

951
       ,option "s" ["source-repository"]
952
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
953 954 955 956 957 958
         getSourceRepository (\v flags -> flags { getSourceRepository = v })
        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")
                                              (fmap (toFlag . Just) parse))
                                  (Flag Nothing)
                                  (map (fmap show) . flagToList))

959 960 961
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")