Setup.hs 89.1 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 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
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
27
    , updateCommand
ijones's avatar
ijones committed
28
    , upgradeCommand
29
    , uninstallCommand
30
    , infoCommand, InfoFlags(..)
31
    , fetchCommand, FetchFlags(..)
32
    , freezeCommand, FreezeFlags(..)
33
    , getCommand, unpackCommand, GetFlags(..)
34
    , checkCommand
35
    , formatCommand
36
    , uploadCommand, UploadFlags(..)
37
    , reportCommand, ReportFlags(..)
refold's avatar
refold committed
38
    , runCommand
39
    , initCommand, IT.InitFlags(..)
40
    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
41
    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
42
    , actAsSetupCommand, ActAsSetupFlags(..)
refold's avatar
refold committed
43
    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
44
    , execCommand, ExecFlags(..)
45
    , userConfigCommand, UserConfigFlags(..)
Maciek Makowski's avatar
Maciek Makowski committed
46
    , manpageCommand
Duncan Coutts's avatar
Duncan Coutts committed
47 48

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

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

68

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

369
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
370
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
371

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

401 402 403 404 405 406 407 408
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

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

defaultConfigExFlags :: ConfigExFlags
416 417
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
418 419 420 421 422

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

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

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

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

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

468
  ]
cheecheeo's avatar
cheecheeo committed
469
  where allowNewerArgument = "DEPS"
470 471 472 473

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

ttuegel's avatar
ttuegel committed
488 489 490 491
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

492 493 494 495 496 497 498 499 500 501
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
502
  option [] ["only"]
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 531 532 533
  "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

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

552 553 554 555
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

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

574 575
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
576 577 578 579 580

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

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

599 600
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
601

602
-- ------------------------------------------------------------
603
-- * Fetch command
604
-- ------------------------------------------------------------
605

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

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

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

       ] ++

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

Duncan Coutts's avatar
Duncan Coutts committed
677 678
  }

679 680 681 682 683 684
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

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

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

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

733 734 735 736 737 738 739 740 741 742
       , 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 [] [])

743 744 745 746 747 748 749 750
       ] ++

       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
751
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
752 753 754

  }

755 756 757 758
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

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

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

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

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

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

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

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

876
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
877

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

921 922 923 924 925 926 927 928 929 930 931 932 933
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

934
-- ------------------------------------------------------------
935
-- * Get flags
936 937
-- ------------------------------------------------------------

938 939 940 941 942 943
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
944

945 946 947 948 949 950
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
951 952
   }

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