Setup.hs 89.4 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, withGlobalRepos
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(..)
Maciek Makowski's avatar
Maciek Makowski committed
42
    , manpageCommand
Duncan Coutts's avatar
Duncan Coutts committed
43 44

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

51
import Distribution.Client.Types
Edsko de Vries's avatar
Edsko de Vries committed
52
         ( Username(..), Password(..), Repo(..), RemoteRepo(..) )
53 54
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
55
import Distribution.Client.Dependency.Types
56
         ( AllowNewer(..), PreSolver(..), ConstraintSource(..) )
57 58
import qualified Distribution.Client.Init.Types as IT
         ( InitFlags(..), PackageType(..) )
59 60
import Distribution.Client.Targets
         ( UserConstraint, readUserConstraint )
61 62
import Distribution.Utils.NubList
         ( NubList, toNubList, fromNubList)
63

64

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

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

117 118
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
119
    commandName         = "",
120 121
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
122 123 124 125
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
126
    commandDescription  = Just $ \pname ->
127 128 129
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
        -- 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"
          ]
165 166
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
167 168 169 170 171 172 173 174 175
        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
176 177
      in
         "Commands:\n"
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
      ++ 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"
214
        , addCmd "sandbox"
215 216 217 218 219
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
220 221
      ++ "\n"
      ++ "For more information about a command use:\n"
222 223
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
224
      ++ "\n"
225
      ++ "To install Cabal packages from hackage use:\n"
226 227
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
228 229
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
230
    commandNotes = Nothing,
231
    commandDefaultFlags = mempty,
232 233 234 235 236 237 238 239 240 241 242
    commandOptions = args
  }
  where
    args :: ShowOrParseArgs -> [OptionField GlobalFlags]
    args ShowArgs  = argsShown
    args ParseArgs = argsShown ++ argsNotShown

    -- arguments we want to show in the help
    argsShown :: [OptionField GlobalFlags]
    argsShown = [
       option ['V'] ["version"]
243 244 245 246 247 248 249 250 251 252 253 254 255 256
         "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")

257
      ,option [] ["sandbox-config-file"]
258
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
259 260 261
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
262 263
      ,option [] ["default-user-config"]
         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
264 265 266
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

267
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
268
         "requiring the presence of a sandbox for sandbox-aware commands"
269 270 271
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

272 273 274 275 276
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

277
      ,option [] ["ignore-expiry"]
Edsko de Vries's avatar
Edsko de Vries committed
278
         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
279 280 281
         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
         trueArg

282
      ,option [] ["http-transport"]
283
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
284 285
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")
286
      ]
287

288 289 290 291
    -- arguments we don't want shown in the help
    argsNotShown :: [OptionField GlobalFlags]
    argsNotShown = [
       option [] ["remote-repo"]
292 293
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
294
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
295 296 297 298 299 300 301 302 303

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

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

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

317 318 319
withGlobalRepos :: Verbosity -> GlobalFlags -> ([Repo] -> IO a) -> IO a
withGlobalRepos _verbosity globalFlags callback =
    callback $ remoteRepos ++ localRepos
320 321
  where
    remoteRepos =
Edsko de Vries's avatar
Edsko de Vries committed
322
      [ RepoRemote remote cacheDir
323
      | remote <- fromNubList $ globalRemoteRepos globalFlags
324 325 326
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
Edsko de Vries's avatar
Edsko de Vries committed
327
      [ RepoLocal local
328
      | local <- fromNubList $ globalLocalRepos globalFlags ]
329 330 331 332

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

334
configureCommand :: CommandUI ConfigFlags
335 336
configureCommand = c
  { commandDefaultFlags = mempty
337 338 339
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
340 341 342 343 344 345
       ++ "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
346
  }
347 348
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
349

350 351 352
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

353
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
354
filterConfigureFlags flags cabalLibVersion
355
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
356
  -- ^ NB: we expect the latest version to be the most common case.
357 358 359
  | 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
360
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
361
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
362
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
363
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
364
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
365
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
366
  | otherwise = flags_latest
367
  where
368
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
369 370
    flags_latest = flags        { configConstraints = [] }

371 372
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
373 374
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
375

376
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
377
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
378

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

408 409 410 411 412 413 414 415
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
416
    configExConstraints:: [(UserConstraint, ConstraintSource)],
417
    configPreferences  :: [Dependency],
418 419
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
420 421 422
  }

defaultConfigExFlags :: ConfigExFlags
423 424
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
425 426 427 428 429

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
430
         liftOptions fst setFst
431
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
432
                  . optionName) $ configureOptions  showOrParseArgs)
433 434
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
435 436 437 438 439
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

440 441 442 443
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
444 445 446 447 448 449 450
  [ 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
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
455 456
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
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
    commandUsage        = usageFlags "freeze",
731 732 733 734 735 736 737 738 739
    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

740 741 742 743 744 745 746 747 748 749
       , 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 [] [])

750 751 752 753 754 755 756 757
       ] ++

       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
758
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
759 760 761

  }

762 763 764 765
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

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

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

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

802 803 804
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
805
    commandSynopsis     = "Check the package for common mistakes.",
806 807 808 809 810 811
    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",
812
    commandNotes        = Nothing,
813
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
814
    commandDefaultFlags = toFlag normal,
815
    commandOptions      = \_ -> []
816 817
  }

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

829 830 831 832 833 834 835 836 837 838 839
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      = \_ -> []
  }

Maciek Makowski's avatar
Maciek Makowski committed
840 841 842 843 844 845 846 847 848 849 850 851
manpageCommand :: CommandUI (Flag Verbosity)
manpageCommand = CommandUI {
    commandName         = "manpage",
    commandSynopsis     = "Outputs manpage source.",
    commandDescription  = Just $ \_ ->
      "Output manpage source to STDOUT.\n",
    commandNotes        = Nothing,
    commandUsage        = usageFlags "manpage",
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> [optionVerbosity id const]
  }

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

883
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
884

885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902
-- ------------------------------------------------------------
-- * 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
903 904 905
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
906 907
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
908
         "You can store your Hackage login in the ~/.cabal/config file\n",
909
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925
    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))
      ]
926 927
  }

928 929 930 931 932 933 934 935 936 937 938 939 940
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

941
-- ------------------------------------------------------------
942
-- * Get flags
943 944
-- ------------------------------------------------------------

945 946 947 948 949 950
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }