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

    , parsePackageArgs
41 42 43
    --TODO: stop exporting these:
    , showRepo
    , parseRepo
44 45
    ) where

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

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

92 93
import Data.Char
         ( isSpace, isAlphaNum )
94 95
import Data.List
         ( intercalate )
96
import Data.Maybe
97
         ( listToMaybe, maybeToList, fromMaybe )
98 99 100 101 102 103 104 105
import Data.Monoid
         ( Monoid(..) )
import Control.Monad
         ( liftM )
import System.FilePath
         ( (</>) )
import Network.URI
         ( parseAbsoluteURI, uriToString )
106

107 108 109 110 111 112
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
113 114 115 116
    globalVersion           :: Flag Bool,
    globalNumericVersion    :: Flag Bool,
    globalConfigFile        :: Flag FilePath,
    globalSandboxConfigFile :: Flag FilePath,
117
    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
118
    globalCacheDir          :: Flag FilePath,
119
    globalLocalRepos        :: NubList FilePath,
120
    globalLogsDir           :: Flag FilePath,
121
    globalWorldFile         :: Flag FilePath,
122 123
    globalRequireSandbox    :: Flag Bool,
    globalIgnoreSandbox     :: Flag Bool
124
  }
Duncan Coutts's avatar
Duncan Coutts committed
125

126 127
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
128 129 130 131
    globalVersion           = Flag False,
    globalNumericVersion    = Flag False,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
132
    globalRemoteRepos       = mempty,
133 134 135
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
136
    globalWorldFile         = mempty,
137 138
    globalRequireSandbox    = Flag False,
    globalIgnoreSandbox     = Flag False
139 140
  }

141 142
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
143
    commandName         = "",
144 145
    commandSynopsis     =
         "Command line interface to the Haskell Cabal infrastructure.",
146 147 148 149
    commandUsage        = \pname ->
         "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
150
    commandDescription  = Just $ \pname ->
151 152 153 154 155 156 157 158 159 160 161
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
      in
         "Commands:\n"
      ++ unlines [ "  " ++ align name ++ "    " ++ description
                 | (name, description) <- cmdDescs ]
      ++ "\n"
      ++ "For more information about a command use:\n"
162 163 164 165
      ++ "  " ++ pname ++ " COMMAND --help\n"
      ++ "or\n"
      ++ "  " ++ pname ++ " help COMMAND\n"
      ++ "\n"
166
      ++ "To install Cabal packages from hackage use:\n"
167 168
      ++ "  " ++ pname ++ " install foo [--dry-run]\n"
      ++ "\n"
169 170
      ++ "Occasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n",
171
    commandNotes = Nothing,
172
    commandDefaultFlags = mempty,
173
    commandOptions      = \showOrParseArgs ->
174
      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
      [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")

190 191 192 193 194 195
      ,option [] ["sandbox-config-file"]
         "Set an alternate location for the sandbox config file \
         \(default: './cabal.sandbox.config')"
         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
         (reqArgFlag "FILE")

196
      ,option [] ["require-sandbox"]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
197
         "requiring the presence of a sandbox for sandbox-aware commands"
198 199 200
         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))

201 202 203 204 205
      ,option [] ["ignore-sandbox"]
         "Ignore any existing sandbox"
         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
         trueArg

206 207 208
      ,option [] ["remote-repo"]
         "The name and url for a remote repository"
         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
209
         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))
210 211 212 213 214 215 216 217 218

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

221 222 223 224 225
      ,option [] ["logs-dir"]
         "The location to put log files"
         globalLogsDir (\v flags -> flags { globalLogsDir = v })
         (reqArgFlag "DIR")

226 227 228 229
      ,option [] ["world-file"]
         "The location of the world file"
         globalWorldFile (\v flags -> flags { globalWorldFile = v })
         (reqArgFlag "FILE")
230 231 232 233 234
      ]
  }

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
235 236 237 238 239 240 241 242
    globalVersion           = mempty,
    globalNumericVersion    = mempty,
    globalConfigFile        = mempty,
    globalSandboxConfigFile = mempty,
    globalRemoteRepos       = mempty,
    globalCacheDir          = mempty,
    globalLocalRepos        = mempty,
    globalLogsDir           = mempty,
243
    globalWorldFile         = mempty,
244 245
    globalRequireSandbox    = mempty,
    globalIgnoreSandbox     = mempty
246 247
  }
  mappend a b = GlobalFlags {
248 249 250 251 252 253 254 255
    globalVersion           = combine globalVersion,
    globalNumericVersion    = combine globalNumericVersion,
    globalConfigFile        = combine globalConfigFile,
    globalSandboxConfigFile = combine globalConfigFile,
    globalRemoteRepos       = combine globalRemoteRepos,
    globalCacheDir          = combine globalCacheDir,
    globalLocalRepos        = combine globalLocalRepos,
    globalLogsDir           = combine globalLogsDir,
256
    globalWorldFile         = combine globalWorldFile,
257 258
    globalRequireSandbox    = combine globalRequireSandbox,
    globalIgnoreSandbox     = combine globalIgnoreSandbox
Duncan Coutts's avatar
Duncan Coutts committed
259
  }
260 261 262 263 264 265 266
    where combine field = field a `mappend` field b

globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
  where
    remoteRepos =
      [ Repo (Left remote) cacheDir
267
      | remote <- fromNubList $ globalRemoteRepos globalFlags
268 269 270 271
      , let cacheDir = fromFlag (globalCacheDir globalFlags)
                   </> remoteRepoName remote ]
    localRepos =
      [ Repo (Right LocalRepo) local
272
      | local <- fromNubList $ globalLocalRepos globalFlags ]
273 274 275 276

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

278
configureCommand :: CommandUI ConfigFlags
279
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
280
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
281 282
  }

283 284 285
configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand

286
filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
287
filterConfigureFlags flags cabalLibVersion
288
  | cabalLibVersion >= Version [1,19,2] [] = flags_latest
289 290 291
  | 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
292
  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0
293
  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0
294
  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1
295
  | otherwise = flags_latest
296
  where
297
    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
298 299
    flags_latest = flags        { configConstraints = [] }

300 301 302 303 304
    -- Cabal < 1.19.2 doesn't know about '--exact-configuration'.
    flags_1_19_1 = flags_latest { configExactConfiguration = NoFlag }
    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
    flags_1_19_0 = flags_1_19_1 { configDependencies = []
                                , configConstraints  = configConstraints flags }
305
    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
306
    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []
307 308
                                , configInstallDirs = configInstallDirs_1_18_0}
    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }
309
    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
310
    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }
311
    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.
312
    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }
313
    -- Cabal < 1.3.10 does not grok the '--constraints' flag.
314
    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
315

316 317 318 319 320 321 322 323
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------

-- | cabal configure takes some extra flags beyond runghc Setup configure
--
data ConfigExFlags = ConfigExFlags {
    configCabalVersion :: Flag Version,
324
    configExConstraints:: [UserConstraint],
325
    configPreferences  :: [Dependency],
326 327
    configSolver       :: Flag PreSolver,
    configAllowNewer   :: Flag AllowNewer
328 329 330
  }

defaultConfigExFlags :: ConfigExFlags
331 332
defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver
                              , configAllowNewer = Flag AllowNewerNone }
333 334 335 336 337

configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
    commandDefaultFlags = (mempty, defaultConfigExFlags),
    commandOptions      = \showOrParseArgs ->
338
         liftOptions fst setFst
339
         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
340
                  . optionName) $ configureOptions  showOrParseArgs)
341 342 343 344 345 346 347 348 349 350 351 352 353 354 355
      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
  }
  where
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs =
  [ 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))
356 357 358 359 360 361
  , option [] ["constraint"]
      "Specify constraints on a package (version, installed/source, flags)"
      configExConstraints (\v flags -> flags { configExConstraints = v })
      (reqArg "CONSTRAINT"
              (fmap (\x -> [x]) (ReadE readUserConstraint))
              (map display))
362 363 364 365

  , option [] ["preference"]
      "Specify preferences (soft constraints) on the version of a package"
      configPreferences (\v flags -> flags { configPreferences = v })
366 367 368 369
      (reqArg "CONSTRAINT"
              (readP_to_E (const "dependency expected")
                          (fmap (\x -> [x]) parse))
              (map display))
370 371

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

  , option [] ["allow-newer"]
cheecheeo's avatar
cheecheeo committed
374
    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
375
    configAllowNewer (\v flags -> flags { configAllowNewer = v})
cheecheeo's avatar
cheecheeo committed
376
    (optArg allowNewerArgument
377 378 379
     (fmap Flag allowNewerParser) (Flag AllowNewerAll)
     allowNewerPrinter)

380
  ]
cheecheeo's avatar
cheecheeo committed
381
  where allowNewerArgument = "DEPS"
382 383 384 385

instance Monoid ConfigExFlags where
  mempty = ConfigExFlags {
    configCabalVersion = mempty,
386
    configExConstraints= mempty,
387
    configPreferences  = mempty,
388 389
    configSolver       = mempty,
    configAllowNewer   = mempty
390 391 392
  }
  mappend a b = ConfigExFlags {
    configCabalVersion = combine configCabalVersion,
393
    configExConstraints= combine configExConstraints,
394
    configPreferences  = combine configPreferences,
395 396
    configSolver       = combine configSolver,
    configAllowNewer   = combine configAllowNewer
397 398 399
  }
    where combine field = field a `mappend` field b

ttuegel's avatar
ttuegel committed
400 401 402 403
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

404 405 406 407 408 409 410 411 412 413
data SkipAddSourceDepsCheck =
  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
  deriving Eq

data BuildExFlags = BuildExFlags {
  buildOnly     :: Flag SkipAddSourceDepsCheck
}

buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
414
  option [] ["only"]
415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
  "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

-- ------------------------------------------------------------
446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
-- * 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

464 465 466 467
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------

468
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
469
testCommand = parent {
470 471
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
472
  commandOptions      =
473
    \showOrParseArgs -> liftOptions get1 set1
474 475
                        (commandOptions parent showOrParseArgs)
                        ++
476 477 478 479
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
480 481
  }
  where
482 483 484
    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)
485

486 487
    parent   = Cabal.testCommand
    progConf = defaultProgramConfiguration
488 489 490 491 492

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

493
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
494
benchmarkCommand = parent {
495 496
  commandDefaultFlags = (commandDefaultFlags parent,
                         Cabal.defaultBuildFlags, mempty),
497
  commandOptions      =
498
    \showOrParseArgs -> liftOptions get1 set1
499 500
                        (commandOptions parent showOrParseArgs)
                        ++
501 502 503 504
                        liftOptions get2 set2
                        (Cabal.buildOptions progConf showOrParseArgs)
                        ++
                        liftOptions get3 set3 (buildExOptions showOrParseArgs)
ttuegel's avatar
ttuegel committed
505
  }
506
  where
507 508 509
    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)
510

511 512
    parent   = Cabal.benchmarkCommand
    progConf = defaultProgramConfiguration
ttuegel's avatar
ttuegel committed
513

514
-- ------------------------------------------------------------
515
-- * Fetch command
516
-- ------------------------------------------------------------
517

518 519 520 521
data FetchFlags = FetchFlags {
--    fetchOutput    :: Flag FilePath,
      fetchDeps      :: Flag Bool,
      fetchDryRun    :: Flag Bool,
522
      fetchSolver           :: Flag PreSolver,
523 524 525
      fetchMaxBackjumps     :: Flag Int,
      fetchReorderGoals     :: Flag Bool,
      fetchIndependentGoals :: Flag Bool,
526
      fetchShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
527
      fetchStrongFlags      :: Flag Bool,
528 529 530 531 532 533 534 535
      fetchVerbosity :: Flag Verbosity
    }

defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
--  fetchOutput    = mempty,
    fetchDeps      = toFlag True,
    fetchDryRun    = toFlag False,
536 537
    fetchSolver           = Flag defaultSolver,
    fetchMaxBackjumps     = Flag defaultMaxBackjumps,
538
    fetchReorderGoals     = Flag False,
539
    fetchIndependentGoals = Flag False,
540
    fetchShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
541
    fetchStrongFlags      = Flag False,
542 543 544 545
    fetchVerbosity = toFlag normal
   }

fetchCommand :: CommandUI FetchFlags
Duncan Coutts's avatar
Duncan Coutts committed
546 547
fetchCommand = CommandUI {
    commandName         = "fetch",
548
    commandSynopsis     = "Downloads packages for later installation.",
549 550 551 552 553
    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",
554
    commandNotes        = Nothing,
555
    commandDefaultFlags = defaultFetchFlags,
556
    commandOptions      = \ showOrParseArgs -> [
557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577
         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
578 579 580 581

       ] ++

       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :
582 583
       optionSolverFlags showOrParseArgs
                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
584 585
                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
586
                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
Andres Löh's avatar
Andres Löh committed
587
                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
588

Duncan Coutts's avatar
Duncan Coutts committed
589 590
  }

591 592 593 594 595 596
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------

data FreezeFlags = FreezeFlags {
      freezeDryRun           :: Flag Bool,
597 598
      freezeTests            :: Flag Bool,
      freezeBenchmarks       :: Flag Bool,
599 600 601 602 603
      freezeSolver           :: Flag PreSolver,
      freezeMaxBackjumps     :: Flag Int,
      freezeReorderGoals     :: Flag Bool,
      freezeIndependentGoals :: Flag Bool,
      freezeShadowPkgs       :: Flag Bool,
Andres Löh's avatar
Andres Löh committed
604
      freezeStrongFlags      :: Flag Bool,
605 606 607 608 609 610
      freezeVerbosity        :: Flag Verbosity
    }

defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
    freezeDryRun           = toFlag False,
611 612
    freezeTests            = toFlag False,
    freezeBenchmarks       = toFlag False,
613 614
    freezeSolver           = Flag defaultSolver,
    freezeMaxBackjumps     = Flag defaultMaxBackjumps,
615
    freezeReorderGoals     = Flag False,
616 617
    freezeIndependentGoals = Flag False,
    freezeShadowPkgs       = Flag False,
Andres Löh's avatar
Andres Löh committed
618
    freezeStrongFlags      = Flag False,
619 620 621 622 623 624 625
    freezeVerbosity        = toFlag normal
   }

freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
626 627 628 629 630 631 632 633
    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",
634
    commandNotes        = Nothing,
635 636 637
    commandUsage        = usageAlternatives "freeze" [""
                                                     ,"PACKAGES"
                                                     ],
638 639 640 641 642 643 644 645 646
    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

647 648 649 650 651 652 653 654 655 656
       , 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 [] [])

657 658 659 660 661 662 663 664
       ] ++

       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
665
                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })
666 667 668

  }

669 670 671 672
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------

673
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
674 675
updateCommand = CommandUI {
    commandName         = "update",
676
    commandSynopsis     = "Updates list of known packages.",
677 678 679
    commandDescription  = Just $ \_ ->
      "For all known remote repositories, download the package list.\n",
    commandNotes        = Just $ \_ ->
680 681 682
      relevantConfigValuesText ["remote-repo"
                               ,"remote-repo-cache"
                               ,"local-repo"],
refold's avatar
refold committed
683
    commandUsage        = usageFlags "update",
684
    commandDefaultFlags = toFlag normal,
685
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
686 687
  }

688
upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
689
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
690
    commandName         = "upgrade",
691
    commandSynopsis     = "(command disabled, use install instead)",
ijones's avatar
ijones committed
692
    commandDescription  = Nothing,
refold's avatar
refold committed
693
    commandUsage        = usageFlagsOrPackages "upgrade",
694
    commandDefaultFlags = (mempty, mempty, mempty, mempty),
695
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
696 697
  }

Duncan Coutts's avatar
Duncan Coutts committed
698 699 700 701 702 703 704 705 706 707 708
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

709 710 711
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
712
    commandSynopsis     = "Check the package for common mistakes.",
713 714 715 716 717 718
    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",
719
    commandNotes        = Nothing,
720
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
721
    commandDefaultFlags = toFlag normal,
722
    commandOptions      = \_ -> []
723 724
  }

725 726 727 728 729
formatCommand  :: CommandUI (Flag Verbosity)
formatCommand = CommandUI {
    commandName         = "format",
    commandSynopsis     = "Reformat the .cabal file using the standard style.",
    commandDescription  = Nothing,
730
    commandNotes        = Nothing,
731
    commandUsage        = usageAlternatives "format" ["[FILE]"],
732 733 734 735
    commandDefaultFlags = toFlag normal,
    commandOptions      = \_ -> []
  }

736
runCommand :: CommandUI (BuildFlags, BuildExFlags)
refold's avatar
refold committed
737 738
runCommand = CommandUI {
    commandName         = "run",
739 740 741 742 743
    commandSynopsis     = "Builds and runs an executable.",
    commandDescription  = Just $ \_ -> wrapText $
         "Builds and then runs the specified executable. If no executable is "
      ++ "specified, but the package contains just one executable, that one "
      ++ "is built and executed.\n",
744
    commandNotes        = Nothing,
745 746
    commandUsage        = usageAlternatives "run"
        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
refold's avatar
refold committed
747
    commandDefaultFlags = mempty,
748 749
    commandOptions      =
      \showOrParseArgs -> liftOptions fst setFst
750
                          (commandOptions parent showOrParseArgs)
751 752 753
                          ++
                          liftOptions snd setSnd
                          (buildExOptions showOrParseArgs)
refold's avatar
refold committed
754 755
  }
  where
756 757 758
    setFst a (_,b) = (a,b)
    setSnd b (a,_) = (a,b)

759
    parent = Cabal.buildCommand defaultProgramConfiguration
refold's avatar
refold committed
760

761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778
-- ------------------------------------------------------------
-- * 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
779 780 781
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
782 783
    commandDescription  = Nothing,
    commandNotes        = Just $ \_ ->
784
         "You can store your Hackage login in the ~/.cabal/config file\n",
785
    commandUsage        = usageAlternatives "report" ["[FLAGS]"],
786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801
    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))
      ]
802 803
  }

804 805 806 807 808 809 810 811 812 813 814 815 816
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

817
-- ------------------------------------------------------------
818
-- * Get flags
819 820
-- ------------------------------------------------------------

821 822 823 824 825 826
data GetFlags = GetFlags {
    getDestDir          :: Flag FilePath,
    getPristine         :: Flag Bool,
    getSourceRepository :: Flag (Maybe RepoKind),
    getVerbosity        :: Flag Verbosity
  }
827

828 829 830 831 832 833
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = toFlag normal
834 835
   }

836 837 838
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
    commandName         = "get",
839 840
    commandSynopsis     = "Download/Extract a package's source code (repository).",
    commandDescription  = Just $ \_ -> wrapText $
841 842 843 844
          "Creates a local copy of a package's source code. By default it gets "
       ++ "the source\ntarball and unpacks it in a local subdirectory. "
       ++ "Alternatively, with -s it will\nget the code from the source "
       ++ "repository specified by the package.\n",
845
    commandNotes        = Nothing,
846
    commandUsage        = usagePackages "get",
847
    commandDefaultFlags = defaultGetFlags,
848
    commandOptions      = \_ -> [
849
        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
850 851

       ,option "d" ["destdir"]
refold's avatar
refold committed
852
         "Where to place the package source, defaults to the current directory."
853
         getDestDir (\v flags -> flags { getDestDir = v })
854
         (reqArgFlag "PATH")
855

856
       ,option "s" ["source-repository"]
857
         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
858 859 860 861 862 863
         getSourceRepository (\v flags -> flags { getSourceRepository = v })
        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")
                                              (fmap (toFlag . Just) parse))
                                  (Flag Nothing)
                                  (map (fmap show) . flagToList))

864 865 866
       , option [] ["pristine"]
           ("Unpack the original pristine tarball, rather than updating the "
           ++ ".cabal file with the latest revision from the package archive.")
867
           getPristine (\v flags -> flags { getPristine = v })
868
           trueArg
869 870 871
       ]
  }

872 873 874 875 876 877 878
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
unpackCommand = getCommand {
  commandName  = "unpack",
  commandUsage = usagePackages "unpack"
  }

879
instance Monoid GetFlags where
880 881 882 883 884 885
  mempty = GetFlags {
    getDestDir          = mempty,
    getPristine         = mempty,
    getSourceRepository = mempty,
    getVerbosity        = mempty
    }
886 887 888 889 890
  mappend a b = GetFlags {
    getDestDir          = combine getDestDir,
    getPristine         = combine getPristine,
    getSourceRepository = combine getSourceRepository,
    getVerbosity        = combine getVerbosity
891 892 893
  }
    where combine field = field a `mappend` field b

894 895 896 897 898
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
899
    listInstalled    :: Flag Bool,
900
    listSimpleOutput :: Flag Bool,
901 902
    listVerbosity    :: Flag Verbosity,
    listPackageDBs   :: [Maybe PackageDB]
903 904 905 906
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
907
    listInstalled    = Flag False,
908
    listSimpleOutput = Flag False,
909 910
    listVerbosity    = toFlag normal,
    listPackageDBs   = []
911 912 913 914 915
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
916
    commandSynopsis     = "List packages matching a search string.",
917 918 919 920 921 922 923 924
    commandDescription  = Just $ \_ -> wrapText $
         "List all packages, or all packages matching one of the search"
      ++ " strings.\n"
      ++ "\n"
      ++ "If there is a sandbox in the current directory and "
      ++ "config:ignore-sandbox is False, use the sandbox package database. "
      ++ "Otherwise, use the package database specified with --package-db. "
      ++ "If not specified, use the user package database.\n",
925
    commandNotes        = Nothing,
926 927
    commandUsage        = usageAlternatives "list" [ "[FLAGS]"
                                                   , "[FLAGS] STRINGS"],
928
    commandDefaultFlags = defaultListFlags,
929
    commandOptions      = \_ -> [
930
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
931