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

    , parsePackageArgs
50 51 52
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
53
    , readRepo
54 55
    ) where

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

69

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

109
import Data.Char
110
         ( isAlphaNum )
111
import Data.List
112
         ( intercalate, deleteFirstsBy )
113
import Data.Maybe
114
         ( maybeToList, fromMaybe )
115 116
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
117 118 119 120 121 122
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
123

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

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

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
269 270
      ,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
271 272 273
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

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

279 280 281 282 283
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

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

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

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

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

313 314 315 316 317
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

318 319 320 321
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
322 323 324 325 326
      ]

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

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

344 345 346
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

347
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
348
filterConfigureFlags flags cabalLibVersion
349
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
350
  -- ^ NB: we expect the latest version to be the most common case.
351 352
  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10
  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0
353
  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0
354
  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0
355
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
356
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
357
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
358
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
359
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
360
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
361
  | otherwise = flags_latest
362
  where
363 364 365 366 367
    flags_latest = flags        {
      -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
      configConstraints = [],
      -- Passing '--allow-newer' to Setup.hs is unnecessary, we use
      -- '--exact-configuration' instead.
368
      configAllowNewer  = Just Cabal.AllowNewerNone
369
      }
370

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 404 405 406
    -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'
    -- and '--enable/disable-library-coverage'.
    flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag
                                , configDynExe      = NoFlag }
407
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
408
    flags_1_10_0 = flags_1_12_0 { configTests       = NoFlag }
409
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
410
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
411

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

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
420
    configExConstraints:: [(UserConstraint, ConstraintSource)],
421
    configPreferences  :: [Dependency],
422
    configSolver       :: Flag PreSolver
423
  }
424
  deriving (Eq, Generic)
425 426

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

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

443 444 445 446
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
447 448 449 450 451 452 453
  [ 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))
454 455 456 457
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
458 459
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
460 461 462 463

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

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

471 472 473
  ]

instance Monoid ConfigExFlags where
474
  mempty = gmempty
475 476 477
  mappend = (<>)

instance Semigroup ConfigExFlags where
478
  (<>) = gmappend
479

ttuegel's avatar
ttuegel committed
480 481 482 483
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

484 485 486 487 488 489
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
490
} deriving Generic
491 492 493

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
494
  option [] ["only"]
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
  "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
517
  mempty = gmempty
518 519 520
  mappend = (<>)

instance Semigroup BuildExFlags where
521
  (<>) = gmappend
522 523

-- ------------------------------------------------------------
524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541
-- * 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

542 543 544 545
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

546
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
547
testCommand = parent {
548 549
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
550
  commandOptions      =
551
    \showOrParseArgs -> liftOptions get1 set1
552 553
                        (commandOptions parent showOrParseArgs)
                        ++
554 555 556 557
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
558 559
  }
  where
560 561 562
    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)
563

564 565
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
566 567 568 569 570

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

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

589 590
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
591

592
-- ------------------------------------------------------------
593
-- * Fetch command
594
-- ------------------------------------------------------------
595

596 597 598 599
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
600
      fetchSolver           :: Flag PreSolver,
601 602 603
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
604
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
605
      fetchStrongFlags      :: Flag Bool,
606 607 608 609 610 611 612 613
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
614 615
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
616
    fetchReorderGoals     = Flag False,
617
    fetchIndependentGoals = Flag False,
618
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
619
    fetchStrongFlags      = Flag False,
620 621 622 623
    fetchVerbosity = toFlag normal
   }

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

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
660 661
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
662 663
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
664
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
665
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
666

Duncan Coutts's avatar
Duncan Coutts committed
667 668
  }

669 670 671 672 673 674
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
675 676
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
677 678 679 680 681
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
682
      freezeStrongFlags      :: Flag Bool,
683 684 685 686 687 688
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
689 690
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
691 692
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
693
    freezeReorderGoals     = Flag False,
694 695
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
696
    freezeStrongFlags      = Flag False,
697 698 699 700 701 702 703
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
704 705 706 707 708 709 710 711
    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",
712
    commandNotes        = Nothing,
713
    commandUsage        = usageFlags "freeze",
714 715 716 717 718 719 720 721 722
    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

723 724 725 726 727 728 729 730 731 732
       , 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 [] [])

733 734 735 736 737 738 739 740
       ] ++

       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
741
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
742 743 744

  }

745 746 747 748
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

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

764
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
765
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
766
    commandName         = "upgrade",
767
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
768
    commandDescription  = Nothing,
refold's avatar
refold committed
769
    commandUsage        = usageFlagsOrPackages "upgrade",
770
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
771
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
772 773
  }

Duncan Coutts's avatar
Duncan Coutts committed
774 775 776 777 778 779 780 781 782 783 784
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

785 786 787
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
788
    commandSynopsis     = "Check the package for common mistakes.",
789 790 791 792 793 794
    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",
795
    commandNotes        = Nothing,
796
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
797
    commandDefaultFlags = toFlag normal,
798
    commandOptions      = \_ -> []
799 800
  }

801 802 803 804 805
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
806
    commandNotes        = Nothing,
807
    commandUsage        = usageAlternatives "format" ["[FILE]"],
808 809 810 811
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

812 813 814 815 816 817 818 819 820 821 822
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
823 824 825 826 827 828 829 830 831 832 833 834
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]
  }

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

866
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
867

868 869 870 871 872 873 874 875
-- ------------------------------------------------------------
-- * Report flags
-- ------------------------------------------------------------

data ReportFlags = ReportFlags {
    reportUsername  :: Flag Username,
    reportPassword  :: Flag Password,
    reportVerbosity :: Flag Verbosity
876
  } deriving Generic
877 878 879 880 881 882 883 884 885

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

reportCommand :: CommandUI ReportFlags
886 887 888
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
889 890
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
891
         "You can store your Hackage login in the ~/.cabal/config file\n",
892
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908
    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))
      ]
909 910
  }

911
instance Monoid ReportFlags where
912
  mempty = gmempty
913 914 915
  mappend = (<>)

instance Semigroup ReportFlags where
916
  (<>) = gmappend
917

918
-- ------------------------------------------------------------
919
-- * Get flags
920 921
-- ------------------------------------------------------------

922 923 924 925 926
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
927
  } deriving Generic
928

929