Setup.hs 90.6 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, globalRepos
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(..)
Duncan Coutts's avatar
Duncan Coutts committed
42 43

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

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

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

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

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

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

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

151 152
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
153
    commandName         = "",
154 155
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
156 157 158 159
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
160
    commandDescription  = Just $ \pname ->
161 162 163
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
164 165 166 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
        -- 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"
          ]
199 200
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
201 202 203 204 205 206 207 208 209
        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
210 211
      in
         "Commands:\n"
212 213 214 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
      ++ 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"
248
        , addCmd "sandbox"
249 250 251 252 253
        , addCmd "exec"
        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."
        ] ++ if null otherCmds then [] else par
                                           :startGroup "other"
                                           :[addCmd n | n <- otherCmds])
254 255
      ++ "\n"
      ++ "For more information about a command use:\n"
256 257
      ++ "   " ++ pname ++ " COMMAND --help\n"
      ++ "or " ++ pname ++ " help COMMAND\n"
258
      ++ "\n"
259
      ++ "To install Cabal packages from hackage use:\n"
260 261
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
262 263
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
264
    commandNotes = Nothing,
265
    commandDefaultFlags = mempty,
266
    commandOptions      = \showOrParseArgs ->
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
267
      (case showOrParseArgs of ShowArgs -> take 8; ParseArgs -> id)
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
      [option ['V'] ["version"]
         "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")

283
      ,option [] ["sandbox-config-file"]
284
         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"
285 286 287
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
288 289 290 291 292
      ,option [] ["constraints-file"]
         "Set a location for a global constraints file for projects without their own cabal.config freeze file."
         globalConfigFile (\v flags -> flags {globalConstraintsFile = v})
         (reqArgFlag "FILE")

293
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
294
         "requiring the presence of a sandbox for sandbox-aware commands"
295 296 297
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

298 299 300 301 302
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

303
      ,option [] ["http-transport"]
304
         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
305 306 307
         globalConfigFile (\v flags -> flags { globalHttpTransport = v })
         (reqArgFlag "HttpTransport")

308 309 310
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
311
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
312 313 314 315 316 317 318 319 320

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

323 324 325 326 327
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

328 329 330 331
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
332 333 334 335 336
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
337 338 339 340
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
341
    globalConstraintsFile   = mempty,
342 343 344 345
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
346
    globalWorldFile         = mempty,
347
    globalRequireSandbox    = mempty,
348 349
    globalIgnoreSandbox     = mempty,
    globalHttpTransport     = mempty
350 351
  }
  mappend a b = GlobalFlags {
352 353 354 355
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
356
    globalConstraintsFile   = combine globalConstraintsFile,
357 358 359 360
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
361
    globalWorldFile         = combine globalWorldFile,
362
    globalRequireSandbox    = combine globalRequireSandbox,
363 364
    globalIgnoreSandbox     = combine globalIgnoreSandbox,
    globalHttpTransport     = combine globalHttpTransport
Duncan Coutts's avatar
Duncan Coutts committed
365
  }
366 367 368 369 370 371 372
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
373
      | remote <- fromNubList $ globalRemoteRepos globalFlags
374 375 376 377
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
378
      | local <- fromNubList $ globalLocalRepos globalFlags ]
379 380 381 382

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

384
configureCommand :: CommandUI ConfigFlags
385 386
configureCommand = c
  { commandDefaultFlags = mempty
387 388 389
  , commandNotes = Just $ \pname -> (case commandNotes c of
         Nothing -> ""
         Just n  -> n pname ++ "\n")
390 391 392 393 394 395
       ++ "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
396
  }
397 398
 where
  c = Cabal.configureCommand defaultProgramConfiguration
Duncan Coutts's avatar
Duncan Coutts committed
399

400 401 402
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

403
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
404
filterConfigureFlags flags cabalLibVersion
405
  | cabalLibVersion >= Version [1,23,0] [] = flags_latest
406
  -- ^ NB: we expect the latest version to be the most common case.
407 408 409
  | 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
410
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
411
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
412
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
413
  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0
414
  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0
415
  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0
416
  | otherwise = flags_latest
417
  where
418
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
419 420
    flags_latest = flags        { configConstraints = [] }

421 422 423 424
    -- Cabal < 1.23 doesn't know about '--profiling-detail'.
    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag
                                , configProfLibDetail = NoFlag }

425
    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.
426
    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }
427

428
    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
429 430
    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'
    flags_1_20_0 =
431
      flags_1_21_0 { configRelocatable = NoFlag
432 433 434 435
                   , configProf = NoFlag
                   , configProfExe = configProf flags
                   , configProfLib =
                     mappend (configProf flags) (configProfLib flags)
436 437
                   , configCoverage = NoFlag
                   , configLibCoverage = configCoverage flags
438
                   }
439 440 441 442
    -- 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 }
443 444 445
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
446
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
447
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
448 449
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
450
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
451
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
452
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
453
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
454
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
455
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
456

457 458 459 460 461 462 463 464
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
465
    configExConstraints:: [(UserConstraint, ConstraintSource)],
466
    configPreferences  :: [Dependency],
467 468
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
469 470 471
  }

defaultConfigExFlags :: ConfigExFlags
472 473
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
474 475 476 477 478

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
479
         liftOptions fst setFst
480
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
481
                  . optionName) $ configureOptions  showOrParseArgs)
482 483
      ++ liftOptions snd setSnd
         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
484 485 486 487 488
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

489 490 491 492
configureExOptions :: ShowOrParseArgs
                   -> ConstraintSource
                   -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
493 494 495 496 497 498 499
  [ 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))
500 501 502 503
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
504 505
              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
              (map $ display . fst))
506 507 508 509

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
510 511 512 513
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
514 515

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
518
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
519
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
520
    (optArg allowNewerArgument
521 522 523
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

524
  ]
cheecheeo's avatar
cheecheeo committed
525
  where allowNewerArgument = "DEPS"
526 527 528 529

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
530
    configExConstraints= mempty,
531
    configPreferences  = mempty,
532 533
    configSolver       = mempty,
    configAllowNewer   = mempty
534 535 536
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
537
    configExConstraints= combine configExConstraints,
538
    configPreferences  = combine configPreferences,
539 540
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
541 542 543
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
544 545 546 547
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

548 549 550 551 552 553 554 555 556 557
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
558
  option [] ["only"]
559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589
  "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

-- ------------------------------------------------------------
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607
-- * 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

608 609 610 611
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

612
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
613
testCommand = parent {
614 615
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
616
  commandOptions      =
617
    \showOrParseArgs -> liftOptions get1 set1
618 619
                        (commandOptions parent showOrParseArgs)
                        ++
620 621 622 623
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
624 625
  }
  where
626 627 628
    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)
629

630 631
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
632 633 634 635 636

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

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

655 656
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
657

658
-- ------------------------------------------------------------
659
-- * Fetch command
660
-- ------------------------------------------------------------
661

662 663 664 665
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
666
      fetchSolver           :: Flag PreSolver,
667 668 669
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
670
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
671
      fetchStrongFlags      :: Flag Bool,
672 673 674 675 676 677 678 679
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
680 681
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
682
    fetchReorderGoals     = Flag False,
683
    fetchIndependentGoals = Flag False,
684
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
685
    fetchStrongFlags      = Flag False,
686 687 688 689
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
690 691
fetchCommand = CommandUI {
    commandName         = "fetch",
692
    commandSynopsis     = "Downloads packages for later installation.",
693 694 695 696 697
    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",
698
    commandNotes        = Nothing,
699
    commandDefaultFlags = defaultFetchFlags,
700
    commandOptions      = \ showOrParseArgs -> [
701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721
         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
722 723 724 725

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
726 727
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
728 729
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
730
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
731
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
732

Duncan Coutts's avatar
Duncan Coutts committed
733 734
  }

735 736 737 738 739 740
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
741 742
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
743 744 745 746 747
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
748
      freezeStrongFlags      :: Flag Bool,
749 750 751 752 753 754
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
755 756
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
757 758
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
759
    freezeReorderGoals     = Flag False,
760 761
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
762
    freezeStrongFlags      = Flag False,
763 764 765 766 767 768 769
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
770 771 772 773 774 775 776 777
    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",
778
    commandNotes        = Nothing,
779
    commandUsage        = usageFlags "freeze",
780 781 782 783 784 785 786 787 788
    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

789 790 791 792 793 794 795 796 797 798
       , 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 [] [])

799 800 801 802 803 804 805 806
       ] ++

       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
807
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
808 809 810

  }

811 812 813 814
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

815
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
816 817
updateCommand = CommandUI {
    commandName         = "update",
818
    commandSynopsis     = "Updates list of known packages.",
819 820 821
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
822 823 824
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
825
    commandUsage        = usageFlags "update",
826
    commandDefaultFlags = toFlag normal,
827
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
828 829
  }

830
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
831
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
832
    commandName         = "upgrade",
833
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
834
    commandDescription  = Nothing,
refold's avatar
refold committed
835
    commandUsage        = usageFlagsOrPackages "upgrade",
836
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
837
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
838 839
  }

Duncan Coutts's avatar
Duncan Coutts committed
840 841 842 843 844 845 846 847 848 849 850
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

851 852 853
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
854
    commandSynopsis     = "Check the package for common mistakes.",
855 856 857 858 859 860
    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",
861
    commandNotes        = Nothing,
862
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
863
    commandDefaultFlags = toFlag normal,
864
    commandOptions      = \_ -> []
865 866
  }

867 868 869 870 871
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
872
    commandNotes        = Nothing,
873
    commandUsage        = usageAlternatives "format" ["[FILE]"],
874 875 876 877
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

878 879 880 881 882 883 884 885 886 887 888
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      = \_ -> []
  }

889
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
890 891
runCommand = CommandUI {
    commandName         = "run",
892
    commandSynopsis     = "Builds and runs an executable.",
893
    commandDescription  = Just $ \pname -> wrapText $
894 895
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
896 897 898 899
      ++ "is built and executed.\n"
      ++ "\n"
      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "
      ++ "test-suite and get its full output.\n",
900 901 902 903
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " run\n"
       ++ "    Run the only executable in the current package;\n"
904 905
       ++ "  " ++ pname ++ " run foo -- --fooflag\n"
       ++ "    Works similar to `./foo --fooflag`.\n",
906 907
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
908
    commandDefaultFlags = mempty,
909 910
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
911
                          (commandOptions parent showOrParseArgs)
912 913 914
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
915 916
  }
  where
917 918 919
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

920
    parent = Cabal.buildCommand defaultProgramConfiguration<