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

    , parsePackageArgs
44 45 46
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
47
    , readRepo
48 49
    ) where

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

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

96 97
import Data.Char
         ( isSpace, isAlphaNum )
98
import Data.List
99
         ( intercalate, deleteFirstsBy )
100
import Data.Maybe
101
         ( listToMaybe, maybeToList, fromMaybe )
102
#if !MIN_VERSION_base(4,8,0)
103 104
import Data.Monoid
         ( Monoid(..) )
105
#endif
106 107 108 109 110 111
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
112

113 114 115 116 117 118
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

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

132 133
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
134 135 136 137
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
138
    globalRemoteRepos       = mempty,
139 140 141
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
142
    globalWorldFile         = mempty,
143 144
    globalRequireSandbox    = Flag False,
    globalIgnoreSandbox     = Flag False
145 146
  }

147 148
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
149
    commandName         = "",
150 151
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
152 153 154 155
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
156
    commandDescription  = Just $ \pname ->
157 158 159
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
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 189 190 191 192 193 194
        -- 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"
          ]
195 196
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
197 198 199 200 201 202 203 204 205
        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
206 207
      in
         "Commands:\n"
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
      ++ 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"
244
        , addCmd "sandbox"
245 246 247 248 249
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
250 251
      ++ "\n"
      ++ "For more information about a command use:\n"
252 253
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
254
      ++ "\n"
255
      ++ "To install Cabal packages from hackage use:\n"
256 257
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
258 259
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
260
    commandNotes = Nothing,
261
    commandDefaultFlags = mempty,
262
    commandOptions      = \showOrParseArgs ->
263
      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278
      [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")

279
      ,option [] ["sandbox-config-file"]
280
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
281 282 283
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

284
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
285
         "requiring the presence of a sandbox for sandbox-aware commands"
286 287 288
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

289 290 291 292 293
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

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

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

309 310 311 312 313
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

314 315 316 317
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
318 319 320 321 322
      ]
  }

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

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
355
      | remote <- fromNubList $ globalRemoteRepos globalFlags
356 357 358 359
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
360
      | local <- fromNubList $ globalLocalRepos globalFlags ]
361 362 363 364

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

366
configureCommand :: CommandUI ConfigFlags
367 368
configureCommand = c
  { commandDefaultFlags = mempty
369 370 371
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
372 373 374 375 376 377
       ++ "Examples:\n"
       ++ "  " ++ pname ++ " configure\n"
       ++ "    Configure with defaults;\n"
       ++ "  " ++ pname ++ " configure --enable-tests -fcustomflag\n"
       ++ "    Configure building package including tests,\n"
       ++ "    with some package-specific flag.\n"
Duncan Coutts's avatar
Duncan Coutts committed
378
  }
379 380
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
381

382 383 384
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

385
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
386
filterConfigureFlags flags cabalLibVersion
387
  | cabalLibVersion >= Version [1,22,0] [] = flags_latest
388
  -- ^ NB: we expect the latest version to be the most common case.
389 390 391
  | 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
392
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
393
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
394
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
395
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
396
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
397
  | otherwise = flags_latest
398
  where
399
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
400 401
    flags_latest = flags        { configConstraints = [] }

402 403 404
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
    flags_1_21_0 = flags_latest { configDebugInfo = NoFlag }

405
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
406 407
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
408
      flags_1_21_0 { configRelocatable = NoFlag
409 410 411 412
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
413 414
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
415
                   }
416 417 418 419
    -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and
    -- '--enable-library-stripping'.
    flags_1_19_1 = flags_1_20_0 { configExactConfiguration = NoFlag
                                , configStripLibs = NoFlag }
420 421 422
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
423
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
424
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
425 426
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
427
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
428
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
429
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
430
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
431
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
432
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
433

434 435 436 437 438 439 440 441
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
442
    configExConstraints:: [UserConstraint],
443
    configPreferences  :: [Dependency],
444 445
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
446 447 448
  }

defaultConfigExFlags :: ConfigExFlags
449 450
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
451 452 453 454 455

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
456
         liftOptions fst setFst
457
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
458
                  . optionName) $ configureOptions  showOrParseArgs)
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473
      ++ 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))
474 475 476 477 478 479
  , 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))
480 481 482 483

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

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
490 491

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
492
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
493
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
494
    (optArg allowNewerArgument
495 496 497
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

498
  ]
cheecheeo's avatar
cheecheeo committed
499
  where allowNewerArgument = "DEPS"
500 501 502 503

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
504
    configExConstraints= mempty,
505
    configPreferences  = mempty,
506 507
    configSolver       = mempty,
    configAllowNewer   = mempty
508 509 510
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
511
    configExConstraints= combine configExConstraints,
512
    configPreferences  = combine configPreferences,
513 514
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
515 516 517
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
518 519 520 521
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

522 523 524 525 526 527 528 529 530 531
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
532
  option [] ["only"]
533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
  "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

-- ------------------------------------------------------------
564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581
-- * 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

582 583 584 585
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

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

604 605
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
606 607 608 609 610

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

611
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
612
benchmarkCommand = parent {
613 614
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
615
  commandOptions      =
616
    \showOrParseArgs -> liftOptions get1 set1
617 618
                        (commandOptions parent showOrParseArgs)
                        ++
619 620 621 622
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
623
  }
624
  where
625 626 627
    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)
628

629 630
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
631

632
-- ------------------------------------------------------------
633
-- * Fetch command
634
-- ------------------------------------------------------------
635

636 637 638 639
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
640
      fetchSolver           :: Flag PreSolver,
641 642 643
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
644
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
645
      fetchStrongFlags      :: Flag Bool,
646 647 648 649 650 651 652 653
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
654 655
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
656
    fetchReorderGoals     = Flag False,
657
    fetchIndependentGoals = Flag False,
658
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
659
    fetchStrongFlags      = Flag False,
660 661 662 663
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
664 665
fetchCommand = CommandUI {
    commandName         = "fetch",
666
    commandSynopsis     = "Downloads packages for later installation.",
667 668 669 670 671
    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",
672
    commandNotes        = Nothing,
673
    commandDefaultFlags = defaultFetchFlags,
674
    commandOptions      = \ showOrParseArgs -> [
675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695
         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
696 697 698 699

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
700 701
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
702 703
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
704
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
705
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
706

Duncan Coutts's avatar
Duncan Coutts committed
707 708
  }

709 710 711 712 713 714
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
715 716
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
717 718 719 720 721
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
722
      freezeStrongFlags      :: Flag Bool,
723 724 725 726 727 728
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
729 730
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
731 732
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
733
    freezeReorderGoals     = Flag False,
734 735
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
736
    freezeStrongFlags      = Flag False,
737 738 739 740 741 742 743
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
744 745 746 747 748 749 750 751
    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",
752
    commandNotes        = Nothing,
753
    commandUsage        = usageFlags "freeze",
754 755 756 757 758 759 760 761 762
    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

763 764 765 766 767 768 769 770 771 772
       , 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 [] [])

773 774 775 776 777 778 779 780
       ] ++

       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
781
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
782 783 784

  }

785 786 787 788
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

789
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
790 791
updateCommand = CommandUI {
    commandName         = "update",
792
    commandSynopsis     = "Updates list of known packages.",
793 794 795
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
796 797 798
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
799
    commandUsage        = usageFlags "update",
800
    commandDefaultFlags = toFlag normal,
801
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
802 803
  }

804
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
805
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
806
    commandName         = "upgrade",
807
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
808
    commandDescription  = Nothing,
refold's avatar
refold committed
809
    commandUsage        = usageFlagsOrPackages "upgrade",
810
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
811
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
812 813
  }

Duncan Coutts's avatar
Duncan Coutts committed
814 815 816 817 818 819 820 821 822 823 824
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

825 826 827
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
828
    commandSynopsis     = "Check the package for common mistakes.",
829 830 831 832 833 834
    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",
835
    commandNotes        = Nothing,
836
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
837
    commandDefaultFlags = toFlag normal,
838
    commandOptions      = \_ -> []
839 840
  }

841 842 843 844 845
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
846
    commandNotes        = Nothing,
847
    commandUsage        = usageAlternatives "format" ["[FILE]"],
848 849 850 851
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

852 853 854 855 856 857 858 859 860 861 862
uninstallCommand  :: CommandUI (Flag Verbosity)
uninstallCommand = CommandUI {
    commandName         = "uninstall",
    commandSynopsis     = "Warn about 'uninstall' not being implemented.",
    commandDescription  = Nothing,
    commandNotes        = Nothing,
    commandUsage        = usageAlternatives "uninstall" ["PACKAGES"],
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

863
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
864 865
runCommand = CommandUI {
    commandName         = "run",
866
    commandSynopsis     = "Builds and runs an executable.",
867
    commandDescription  = Just $ \pname -> wrapText $
868 869
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
870 871 872 873
      ++ "is built and executed.\n"
      ++ "\n"
      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "
      ++ "test-suite and get its full output.\n",
874 875 876 877
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " run\n"
       ++ "    Run the only executable in the current package;\n"
878 879
       ++ "  " ++ pname ++ " run foo -- --fooflag\n"
       ++ "    Works similar to `./foo --fooflag`.\n",
880 881
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
882
    commandDefaultFlags = mempty,
883 884
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
885
                          (commandOptions parent showOrParseArgs)
886 887 888
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
889 890
  }
  where
891 892 893
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

894
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
895

896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913
-- ------------------------------------------------------------
-- * 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
914 915 916
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
917 918
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
919
         "You can store your Hackage login in the ~/.cabal/config file\n",
920
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936
    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))
      ]
937 938
  }

939 940 941 942 943 944 945 946 947 948 949 950 951
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

952
-- ------------------------------------------------------------
953
-- * Get flags
954 955
-- ------------------------------------------------------------

956 957