Setup.hs 89 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
Edsko de Vries's avatar
Edsko de Vries committed
15 16
    ( globalCommand, GlobalFlags(..), defaultGlobalFlags
    , RepoContext(..), withRepoContext
17
    , configureCommand, ConfigFlags(..), filterConfigureFlags
18 19
    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
                        , configureExOptions
20
    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
21
    , replCommand, testCommand, benchmarkCommand
22
    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
23
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
24
    , updateCommand
ijones's avatar
ijones committed
25
    , upgradeCommand
26
    , uninstallCommand
27
    , infoCommand, InfoFlags(..)
28
    , fetchCommand, FetchFlags(..)
29
    , freezeCommand, FreezeFlags(..)
30
    , getCommand, unpackCommand, GetFlags(..)
31
    , checkCommand
32
    , formatCommand
33
    , uploadCommand, UploadFlags(..)
34
    , reportCommand, ReportFlags(..)
refold's avatar
refold committed
35
    , runCommand
36
    , initCommand, IT.InitFlags(..)
37
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
38
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
39
    , actAsSetupCommand, ActAsSetupFlags(..)
refold's avatar
refold committed
40
    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
41
    , execCommand, ExecFlags(..)
42
    , userConfigCommand, UserConfigFlags(..)
Maciek Makowski's avatar
Maciek Makowski committed
43
    , manpageCommand
Duncan Coutts's avatar
Duncan Coutts committed
44 45

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

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

65

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

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

120 121
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
122
    commandName         = "",
123 124
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
125 126 127 128
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
129
    commandDescription  = Just $ \pname ->
130 131 132
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
        -- 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"
          ]
168 169
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
170 171 172 173 174 175 176 177 178
        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
179 180
      in
         "Commands:\n"
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 214 215 216
      ++ 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"
217
        , addCmd "sandbox"
218 219 220 221 222
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
223 224
      ++ "\n"
      ++ "For more information about a command use:\n"
225 226
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
227
      ++ "\n"
228
      ++ "To install Cabal packages from hackage use:\n"
229 230
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
231 232
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
233
    commandNotes = Nothing,
234
    commandDefaultFlags = mempty,
235 236 237 238 239 240 241 242 243 244 245
    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"]
246 247 248 249 250 251 252 253 254 255 256 257 258 259
         "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")

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

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
265 266
      ,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
267 268 269
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

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

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

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

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

291 292 293 294
    -- arguments we don't want shown in the help
    argsNotShown :: [OptionField GlobalFlags]
    argsNotShown = [
       option [] ["remote-repo"]
295 296
         "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
      ]

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

324
configureCommand :: CommandUI ConfigFlags
325 326
configureCommand = c
  { commandDefaultFlags = mempty
327 328 329
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
330 331 332 333 334 335
       ++ "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
336
  }
337 338
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
339

340 341 342
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

343
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
344
filterConfigureFlags flags cabalLibVersion
345
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
346
  -- ^ NB: we expect the latest version to be the most common case.
347 348 349
  | 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
350
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
351
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
352
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
353
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
354
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
355
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
356
  | otherwise = flags_latest
357
  where
358
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
359 360
    flags_latest = flags        { configConstraints = [] }

361 362
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
363 364
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
365

366
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
367
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
368

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

398 399 400 401 402 403 404 405
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
406
    configExConstraints:: [(UserConstraint, ConstraintSource)],
407
    configPreferences  :: [Dependency],
408 409
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
410 411 412
  }

defaultConfigExFlags :: ConfigExFlags
413 414
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
415 416 417 418 419

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
420
         liftOptions fst setFst
421
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
422
                  . optionName) $ configureOptions  showOrParseArgs)
423 424
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
425 426 427 428 429
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

430 431 432 433
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
434 435 436 437 438 439 440
  [ 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))
441 442 443 444
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
445 446
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
447 448 449 450

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
451 452 453 454
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
455 456

  , optionSolver configSolver (\v flags -> flags { configSolver = v })
457 458

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
459
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
460
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
461
    (optArg allowNewerArgument
462 463 464
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

465
  ]
cheecheeo's avatar
cheecheeo committed
466
  where allowNewerArgument = "DEPS"
467 468 469 470

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
471
    configExConstraints= mempty,
472
    configPreferences  = mempty,
473 474
    configSolver       = mempty,
    configAllowNewer   = mempty
475 476 477
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
478
    configExConstraints= combine configExConstraints,
479
    configPreferences  = combine configPreferences,
480 481
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
482 483 484
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
485 486 487 488
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

489 490 491 492 493 494 495 496 497 498
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
499
  option [] ["only"]
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530
  "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

-- ------------------------------------------------------------
531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548
-- * 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

549 550 551 552
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

553
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
554
testCommand = parent {
555 556
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
557
  commandOptions      =
558
    \showOrParseArgs -> liftOptions get1 set1
559 560
                        (commandOptions parent showOrParseArgs)
                        ++
561 562 563 564
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
565 566
  }
  where
567 568 569
    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)
570

571 572
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
573 574 575 576 577

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

578
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
579
benchmarkCommand = parent {
580 581
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
582
  commandOptions      =
583
    \showOrParseArgs -> liftOptions get1 set1
584 585
                        (commandOptions parent showOrParseArgs)
                        ++
586 587 588 589
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
590
  }
591
  where
592 593 594
    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)
595

596 597
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
598

599
-- ------------------------------------------------------------
600
-- * Fetch command
601
-- ------------------------------------------------------------
602

603 604 605 606
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
607
      fetchSolver           :: Flag PreSolver,
608 609 610
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
611
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
612
      fetchStrongFlags      :: Flag Bool,
613 614 615 616 617 618 619 620
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
621 622
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
623
    fetchReorderGoals     = Flag False,
624
    fetchIndependentGoals = Flag False,
625
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
626
    fetchStrongFlags      = Flag False,
627 628 629 630
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
631 632
fetchCommand = CommandUI {
    commandName         = "fetch",
633
    commandSynopsis     = "Downloads packages for later installation.",
634 635 636 637 638
    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",
639
    commandNotes        = Nothing,
640
    commandDefaultFlags = defaultFetchFlags,
641
    commandOptions      = \ showOrParseArgs -> [
642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662
         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
663 664 665 666

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
667 668
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
669 670
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
671
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
672
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
673

Duncan Coutts's avatar
Duncan Coutts committed
674 675
  }

676 677 678 679 680 681
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
682 683
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
684 685 686 687 688
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
689
      freezeStrongFlags      :: Flag Bool,
690 691 692 693 694 695
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
696 697
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
698 699
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
700
    freezeReorderGoals     = Flag False,
701 702
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
703
    freezeStrongFlags      = Flag False,
704 705 706 707 708 709 710
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
711 712 713 714 715 716 717 718
    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",
719
    commandNotes        = Nothing,
720
    commandUsage        = usageFlags "freeze",
721 722 723 724 725 726 727 728 729
    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

730 731 732 733 734 735 736 737 738 739
       , 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 [] [])

740 741 742 743 744 745 746 747
       ] ++

       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
748
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
749 750 751

  }

752 753 754 755
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

756
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
757 758
updateCommand = CommandUI {
    commandName         = "update",
759
    commandSynopsis     = "Updates list of known packages.",
760 761 762
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
763 764 765
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
766
    commandUsage        = usageFlags "update",
767
    commandDefaultFlags = toFlag normal,
768
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
769 770
  }

771
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
772
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
773
    commandName         = "upgrade",
774
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
775
    commandDescription  = Nothing,
refold's avatar
refold committed
776
    commandUsage        = usageFlagsOrPackages "upgrade",
777
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
778
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
779 780
  }

Duncan Coutts's avatar
Duncan Coutts committed
781 782 783 784 785 786 787 788 789 790 791
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

792 793 794
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
795
    commandSynopsis     = "Check the package for common mistakes.",
796 797 798 799 800 801
    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",
802
    commandNotes        = Nothing,
803
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
804
    commandDefaultFlags = toFlag normal,
805
    commandOptions      = \_ -> []
806 807
  }

808 809 810 811 812
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
813
    commandNotes        = Nothing,
814
    commandUsage        = usageAlternatives "format" ["[FILE]"],
815 816 817 818
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

819 820 821 822 823 824 825 826 827 828 829
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
830 831 832 833 834 835 836 837 838 839 840 841
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]
  }

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

873
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
874

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

918 919 920 921 922 923 924 925 926 927 928 929 930
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

931
-- ------------------------------------------------------------
932
-- * Get flags
933 934
-- ------------------------------------------------------------

935 936 937 938 939 940
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
941

942 943 944 945 946 947
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
948 949
   }

950 951 952
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
953 954
    commandSynopsis     = "Download/Extract a package's source code (repository).",
    commandDescription  = Just $ \_ -> wrapText $
955 956 957 958