Setup.hs 89.5 KB
Newer Older
1
{-# LANGUAGE CPP #-}
Edsko de Vries's avatar
Edsko de Vries committed
2 3 4
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
5
{-# LANGUAGE DeriveGeneric #-}
6 7
-----------------------------------------------------------------------------
-- |
8
-- Module      :  Distribution.Client.Setup
9 10 11 12 13 14 15 16 17
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
18
module Distribution.Client.Setup
Edsko de Vries's avatar
Edsko de Vries committed
19 20
    ( globalCommand, GlobalFlags(..), defaultGlobalFlags
    , RepoContext(..), withRepoContext
21
    , configureCommand, ConfigFlags(..), filterConfigureFlags
22 23
    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
                        , configureExOptions
24
    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
25
    , replCommand, testCommand, benchmarkCommand
26
    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
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, readS_to_P, char, munch1, pfail,  (+++) )
99 100
import Distribution.Compat.Semigroup
         ( Semigroup((<>)) )
101 102
import Distribution.Verbosity
         ( Verbosity, normal )
103
import Distribution.Simple.Utils
104
         ( wrapText, wrapLine )
105
import Distribution.Client.GlobalFlags
Edsko de Vries's avatar
Edsko de Vries committed
106 107 108
         ( GlobalFlags(..), defaultGlobalFlags
         , RepoContext(..), withRepoContext
         )
109

110
import Data.Char
111
         ( isAlphaNum )
112
import Data.List
113
         ( intercalate, deleteFirstsBy )
114
import Data.Maybe
115
         ( maybeToList, fromMaybe )
116
#if !MIN_VERSION_base(4,8,0)
117 118
import Data.Monoid
         ( Monoid(..) )
119
#endif
120 121
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
122 123 124 125 126 127
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
128

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

269
      ,option [] ["sandbox-config-file"]
270
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
271 272 273
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
274 275
      ,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
276 277 278
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

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

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

289
      ,option [] ["ignore-expiry"]
Edsko de Vries's avatar
Edsko de Vries committed
290
         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
291 292 293
         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
         trueArg

294
      ,option [] ["http-transport"]
295
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
296 297
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")
298
      ]
299

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

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

318 319 320 321 322
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

323 324 325 326
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
327 328 329 330 331
      ]

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

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

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

352
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
353
filterConfigureFlags flags cabalLibVersion
354
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
355
  -- ^ NB: we expect the latest version to be the most common case.
356 357
  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10
  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0
358
  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0
359
  | 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 369 370 371 372
    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.
373
      configAllowNewer  = Cabal.AllowNewerNone
374
      }
375

376 377
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
378 379
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
380

381
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
382
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
383

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

417 418 419 420 421 422 423 424
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
425
    configExConstraints:: [(UserConstraint, ConstraintSource)],
426
    configPreferences  :: [Dependency],
427
    configSolver       :: Flag PreSolver
428
  }
429
  deriving (Eq, Generic)
430 431

defaultConfigExFlags :: ConfigExFlags
432
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }
433 434 435 436 437

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

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

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
469 470 471 472
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
473 474

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

476 477 478 479 480
  ]

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
481
    configExConstraints= mempty,
482
    configPreferences  = mempty,
483
    configSolver       = mempty
484
  }
485 486 487 488
  mappend = (<>)

instance Semigroup ConfigExFlags where
  a <> b = ConfigExFlags {
489
    configCabalVersion = combine configCabalVersion,
490
    configExConstraints= combine configExConstraints,
491
    configPreferences  = combine configPreferences,
492
    configSolver       = combine configSolver
493 494 495
  }
    where combine field = field a `mappend` field b

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

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

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
510
  option [] ["only"]
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
  "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
  }
536 537 538 539
  mappend = (<>)

instance Semigroup BuildExFlags where
  a <> b = BuildExFlags {
540 541 542 543 544
    buildOnly    = combine buildOnly
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562
-- * 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

563 564 565 566
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

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

585 586
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
587 588 589 590 591

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

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

610 611
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
612

613
-- ------------------------------------------------------------
614
-- * Fetch command
615
-- ------------------------------------------------------------
616

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

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

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
645 646
fetchCommand = CommandUI {
    commandName         = "fetch",
647
    commandSynopsis     = "Downloads packages for later installation.",
648 649 650 651 652
    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",
653
    commandNotes        = Nothing,
654
    commandDefaultFlags = defaultFetchFlags,
655
    commandOptions      = \ showOrParseArgs -> [
656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676
         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
677 678 679 680

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
681 682
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
683 684
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
685
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
686
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
687

Duncan Coutts's avatar
Duncan Coutts committed
688 689
  }

690 691 692 693 694 695
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

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

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

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
725 726 727 728 729 730 731 732
    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",
733
    commandNotes        = Nothing,
734
    commandUsage        = usageFlags "freeze",
735 736 737 738 739 740 741 742 743
    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

744 745 746 747 748 749 750 751 752 753
       , 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 [] [])

754 755 756 757 758 759 760 761
       ] ++

       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
762
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
763 764 765

  }

766 767 768 769
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

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

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

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

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

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

833 834 835 836 837 838 839 840 841 842 843
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
844 845 846 847 848 849 850 851 852 853 854 855
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]
  }

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

887
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
888

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

932 933 934 935 936 937
instance Monoid ReportFlags where
  mempty = ReportFlags {
    reportUsername  = mempty,
    reportPassword  = mempty,
    reportVerbosity = mempty
  }
938 939 940 941
  mappend = (<>)

instance Semigroup ReportFlags where
  a <> b = ReportFlags {
942 943 944 945 946 947
    reportUsername  = combine reportUsername,
    reportPassword  = combine reportPassword,
    reportVerbosity = combine reportVerbosity
  }
    where combine field = field a `mappend` field b

948