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

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

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

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

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

114 115 116 117 118 119
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
120 121 122 123
    globalVersion           :: Flag Bool,
    globalNumericVersion    :: Flag Bool,
    globalConfigFile        :: Flag FilePath,
    globalSandboxConfigFile :: Flag FilePath,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
124
    globalConstraintsFile   :: Flag FilePath,
125
    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
126
    globalCacheDir          :: Flag FilePath,
127
    globalLocalRepos        :: NubList FilePath,
128
    globalLogsDir           :: Flag FilePath,
129
    globalWorldFile         :: Flag FilePath,
130
    globalRequireSandbox    :: Flag Bool,
131
    globalIgnoreSandbox     :: Flag Bool,
132
    globalIgnoreExpiry      :: Flag Bool,    -- ^ Ignore security expiry dates
133
    globalHttpTransport     :: Flag String
134
  }
Duncan Coutts's avatar
Duncan Coutts committed
135

136 137
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
138 139 140 141
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
142
    globalConstraintsFile   = mempty,
143
    globalRemoteRepos       = mempty,
144 145 146
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
147
    globalWorldFile         = mempty,
148
    globalRequireSandbox    = Flag False,
149
    globalIgnoreSandbox     = Flag False,
150
    globalIgnoreExpiry      = Flag False,
151
    globalHttpTransport     = mempty
152 153
  }

154 155
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
156
    commandName         = "",
157 158
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
159 160 161 162
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
163
    commandDescription  = Just $ \pname ->
164 165 166
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
        -- 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"
          ]
202 203
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
204 205 206 207 208 209 210 211 212
        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
213 214
      in
         "Commands:\n"
215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250
      ++ 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"
251
        , addCmd "sandbox"
252 253 254 255 256
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
257 258
      ++ "\n"
      ++ "For more information about a command use:\n"
259 260
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
261
      ++ "\n"
262
      ++ "To install Cabal packages from hackage use:\n"
263 264
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
265 266
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
267
    commandNotes = Nothing,
268
    commandDefaultFlags = mempty,
269 270 271 272 273 274 275 276 277 278 279
    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"]
280 281 282 283 284 285 286 287 288 289 290 291 292 293
         "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")

294
      ,option [] ["sandbox-config-file"]
295
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
296 297 298
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
299 300
      ,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
301 302 303
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

304
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
305
         "requiring the presence of a sandbox for sandbox-aware commands"
306 307 308
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

309 310 311 312 313
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

314
      ,option [] ["ignore-expiry"]
Edsko de Vries's avatar
Edsko de Vries committed
315
         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
316 317 318
         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
         trueArg

319
      ,option [] ["http-transport"]
320
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
321 322
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")
323
      ]
324

325 326 327 328
    -- arguments we don't want shown in the help
    argsNotShown :: [OptionField GlobalFlags]
    argsNotShown = [
       option [] ["remote-repo"]
329 330
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
331
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
332 333 334 335 336 337 338 339 340

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

343 344 345 346 347
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

348 349 350 351
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
352 353 354 355
      ]

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
356 357 358 359
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
360
    globalConstraintsFile   = mempty,
361 362 363 364
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
365
    globalWorldFile         = mempty,
366
    globalRequireSandbox    = mempty,
367
    globalIgnoreSandbox     = mempty,
368
    globalIgnoreExpiry      = mempty,
369
    globalHttpTransport     = mempty
370 371
  }
  mappend a b = GlobalFlags {
372 373 374 375
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
376
    globalConstraintsFile   = combine globalConstraintsFile,
377 378 379 380
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
381
    globalWorldFile         = combine globalWorldFile,
382
    globalRequireSandbox    = combine globalRequireSandbox,
383
    globalIgnoreSandbox     = combine globalIgnoreSandbox,
384
    globalIgnoreExpiry      = combine globalIgnoreExpiry,
385
    globalHttpTransport     = combine globalHttpTransport
Duncan Coutts's avatar
Duncan Coutts committed
386
  }
387 388
    where combine field = field a `mappend` field b

389 390 391
withGlobalRepos :: Verbosity -> GlobalFlags -> ([Repo] -> IO a) -> IO a
withGlobalRepos _verbosity globalFlags callback =
    callback $ remoteRepos ++ localRepos
392 393
  where
    remoteRepos =
Edsko de Vries's avatar
Edsko de Vries committed
394
      [ RepoRemote remote cacheDir
395
      | remote <- fromNubList $ globalRemoteRepos globalFlags
396 397 398
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
Edsko de Vries's avatar
Edsko de Vries committed
399
      [ RepoLocal local
400
      | local <- fromNubList $ globalLocalRepos globalFlags ]
401 402 403 404

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

406
configureCommand :: CommandUI ConfigFlags
407 408
configureCommand = c
  { commandDefaultFlags = mempty
409 410 411
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
412 413 414 415 416 417
       ++ "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
418
  }
419 420
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
421

422 423 424
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

425
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
426
filterConfigureFlags flags cabalLibVersion
427
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
428
  -- ^ NB: we expect the latest version to be the most common case.
429 430 431
  | 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
432
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
433
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
434
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
435
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
436
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
437
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
438
  | otherwise = flags_latest
439
  where
440
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
441 442
    flags_latest = flags        { configConstraints = [] }

443 444
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
445 446
                                , configProfLibDetail = NoFlag
                                , configIPID          = NoFlag }
447

448
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
449
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
450

451
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
452 453
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
454
      flags_1_21_0 { configRelocatable = NoFlag
455 456 457 458
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
459 460
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
461
                   }
462 463 464 465
    -- 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 }
466 467 468
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
469
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
470
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
471 472
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
473
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
474
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
475
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
476
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
477
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
478
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
479

480 481 482 483 484 485 486 487
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
488
    configExConstraints:: [(UserConstraint, ConstraintSource)],
489
    configPreferences  :: [Dependency],
490 491
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
492 493 494
  }

defaultConfigExFlags :: ConfigExFlags
495 496
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
497 498 499 500 501

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
502
         liftOptions fst setFst
503
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
504
                  . optionName) $ configureOptions  showOrParseArgs)
505 506
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
507 508 509 510 511
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

512 513 514 515
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
516 517 518 519 520 521 522
  [ 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))
523 524 525 526
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
527 528
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
529 530 531 532

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
533 534 535 536
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
537 538

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
541
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
542
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
543
    (optArg allowNewerArgument
544 545 546
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

547
  ]
cheecheeo's avatar
cheecheeo committed
548
  where allowNewerArgument = "DEPS"
549 550 551 552

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
553
    configExConstraints= mempty,
554
    configPreferences  = mempty,
555 556
    configSolver       = mempty,
    configAllowNewer   = mempty
557 558 559
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
560
    configExConstraints= combine configExConstraints,
561
    configPreferences  = combine configPreferences,
562 563
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
564 565 566
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
567 568 569 570
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

571 572 573 574 575 576 577 578 579 580
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
581
  option [] ["only"]
582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612
  "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

-- ------------------------------------------------------------
613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630
-- * 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

631 632 633 634
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

635
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
636
testCommand = parent {
637 638
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
639
  commandOptions      =
640
    \showOrParseArgs -> liftOptions get1 set1
641 642
                        (commandOptions parent showOrParseArgs)
                        ++
643 644 645 646
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
647 648
  }
  where
649 650 651
    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)
652

653 654
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
655 656 657 658 659

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

660
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
661
benchmarkCommand = parent {
662 663
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
664
  commandOptions      =
665
    \showOrParseArgs -> liftOptions get1 set1
666 667
                        (commandOptions parent showOrParseArgs)
                        ++
668 669 670 671
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
672
  }
673
  where
674 675 676
    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)
677

678 679
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
680

681
-- ------------------------------------------------------------
682
-- * Fetch command
683
-- ------------------------------------------------------------
684

685 686 687 688
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
689
      fetchSolver           :: Flag PreSolver,
690 691 692
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
693
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
694
      fetchStrongFlags      :: Flag Bool,
695 696 697 698 699 700 701 702
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
703 704
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
705
    fetchReorderGoals     = Flag False,
706
    fetchIndependentGoals = Flag False,
707
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
708
    fetchStrongFlags      = Flag False,
709 710 711 712
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
713 714
fetchCommand = CommandUI {
    commandName         = "fetch",
715
    commandSynopsis     = "Downloads packages for later installation.",
716 717 718 719 720
    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",
721
    commandNotes        = Nothing,
722
    commandDefaultFlags = defaultFetchFlags,
723
    commandOptions      = \ showOrParseArgs -> [
724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744
         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
745 746 747 748

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
749 750
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
751 752
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
753
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
754
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
755

Duncan Coutts's avatar
Duncan Coutts committed
756 757
  }

758 759 760 761 762 763
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
764 765
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
766 767 768 769 770
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
771
      freezeStrongFlags      :: Flag Bool,
772 773 774 775 776 777
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
778 779
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
780 781
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
782
    freezeReorderGoals     = Flag False,
783 784
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
785
    freezeStrongFlags      = Flag False,
786 787 788 789 790 791 792
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
793 794 795 796 797 798 799 800
    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",
801
    commandNotes        = Nothing,
802
    commandUsage        = usageFlags "freeze",
803 804 805 806 807 808 809 810 811
    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

812 813 814 815 816 817 818 819 820 821
       , 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 [] [])

822 823 824 825 826 827 828 829
       ] ++

       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
830
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
831 832 833

  }

834 835 836 837
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

838
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
839 840
updateCommand = CommandUI {
    commandName         = "update",
841
    commandSynopsis     = "Updates list of known packages.",
842 843 844
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
845 846 847
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
848
    commandUsage        = usageFlags "update",
849
    commandDefaultFlags = toFlag normal,
850
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
851 852
  }

853
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
854
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
855
    commandName         = "upgrade",
856
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
857
    commandDescription  = Nothing,
refold's avatar
refold committed
858
    commandUsage        = usageFlagsOrPackages "upgrade",
859
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
860
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
861 862
  }

Duncan Coutts's avatar
Duncan Coutts committed
863 864 865 866 867 868 869 870 871 872 873
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

874 875 876
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
877
    commandSynopsis     = "Check the package for common mistakes.",
878 879 880 881 882 883
    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",
884
    commandNotes        = Nothing,
885
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
886
    commandDefaultFlags = toFlag normal,
887
    commandOptions      = \_ -> []
888 889
  }

890 891 892 893 894
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
895
    commandNotes        = Nothing,
896
    commandUsage        = usageAlternatives "format" ["[FILE]"],
897 898 899 900
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

901 902 903 904 905 906 907 908 909 910 911
uninstallCommand  :: CommandUI (Flag Verbosity)