Setup.hs 14.1 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
Duncan Coutts's avatar
Duncan Coutts committed
14
    ( globalCommand, Cabal.GlobalFlags(..)
15
    , configureCommand, filterConfigureFlags
16
    , installCommand, InstallFlags(..)
17
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
18
    , updateCommand
ijones's avatar
ijones committed
19
    , upgradeCommand
Duncan Coutts's avatar
Duncan Coutts committed
20 21
    , infoCommand
    , fetchCommand
22
    , checkCommand
23
    , uploadCommand, UploadFlags(..)
24
    , reportCommand
Duncan Coutts's avatar
Duncan Coutts committed
25 26

    , parsePackageArgs
27 28
    ) where

29 30 31 32 33
import Distribution.Client.Types
         ( Username(..), Password(..) )

import Distribution.Simple.Program
         ( defaultProgramConfiguration )
34 35
import Distribution.Simple.Command hiding (boolOpt)
import qualified Distribution.Simple.Command as Command
Duncan Coutts's avatar
Duncan Coutts committed
36
import qualified Distribution.Simple.Setup as Cabal
37 38
         ( GlobalFlags(..), globalCommand
         , ConfigFlags(..), configureCommand )
39
import Distribution.Simple.Setup
40
         ( Flag(..), toFlag, flagToList, flagToMaybe, trueArg, optionVerbosity )
41
import Distribution.Version
42
         ( Version(Version), VersionRange(..) )
43
import Distribution.Package
44
         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
45 46 47 48
import Distribution.Text
         ( Text(parse), display )
import Distribution.ReadE
         ( readP_to_E )
49 50 51 52
import Distribution.Compat.ReadP
         ( ReadP, readP_to_S, (+++) )
import Distribution.Verbosity
         ( Verbosity, normal )
53

54 55 56 57
import Data.Char     (isSpace)
import Data.Maybe    (listToMaybe)
import Data.Monoid   (Monoid(..))
import Control.Monad (liftM)
58

Duncan Coutts's avatar
Duncan Coutts committed
59 60 61

globalCommand :: CommandUI Cabal.GlobalFlags
globalCommand = Cabal.globalCommand {
62 63 64 65 66 67 68 69 70
    commandDescription = Just $ \pname ->
         "Typical step for installing Cabal packages:\n"
      ++ "  " ++ pname ++ " install [PACKAGES]\n"
      ++ "\nOccasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n"
      ++ "\nFor more information about a command, try '"
          ++ pname ++ " COMMAND --help'."
      ++ "\nThis program is the command line interface to the Haskell Cabal Infrastructure."
      ++ "\nSee http://www.haskell.org/cabal/ for more information.\n"
Duncan Coutts's avatar
Duncan Coutts committed
71 72
  }

73
configureCommand :: CommandUI Cabal.ConfigFlags
74
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
75
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
76 77
  }

78 79 80 81 82 83 84
filterConfigureFlags :: Cabal.ConfigFlags -> Version -> Cabal.ConfigFlags
filterConfigureFlags flags cabalLibVersion
  | cabalLibVersion >= Version [1,3,10] [] = flags
    -- older Cabal does not grok the constraints flag:
  | otherwise = flags { Cabal.configConstraints = [] }


85
fetchCommand :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
86 87 88 89 90
fetchCommand = CommandUI {
    commandName         = "fetch",
    commandSynopsis     = "Downloads packages for later installation or study.",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "fetch",
91
    commandDefaultFlags = toFlag normal,
92
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
93 94
  }

95
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
96 97 98 99 100
updateCommand = CommandUI {
    commandName         = "update",
    commandSynopsis     = "Updates list of known packages",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "update",
101
    commandDefaultFlags = toFlag normal,
102
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
103 104
  }

105
upgradeCommand  :: CommandUI (Cabal.ConfigFlags, InstallFlags)
106
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
107 108 109
    commandName         = "upgrade",
    commandSynopsis     = "Upgrades installed packages to the latest available version",
    commandDescription  = Nothing,
110
    commandUsage        = usagePackages "upgrade",
111
    commandDefaultFlags = (mempty, defaultInstallFlags),
112
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
113 114
  }

Duncan Coutts's avatar
Duncan Coutts committed
115 116 117 118 119 120 121 122 123 124 125
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

126
infoCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
127 128 129 130 131
infoCommand = CommandUI {
    commandName         = "info",
    commandSynopsis     = "Emit some info about dependency resolution",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "info",
132
    commandDefaultFlags = toFlag normal,
133
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
134 135
  }

136 137 138 139 140 141
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
    commandSynopsis     = "Check the package for common mistakes",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
142 143 144 145 146 147 148 149 150 151 152
    commandDefaultFlags = toFlag normal,
    commandOptions      = mempty
  }

reportCommand :: CommandUI (Flag Verbosity)
reportCommand = CommandUI {
    commandName         = "report",
    commandSynopsis     = "Upload build reports to a remote server.",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " report\n",
    commandDefaultFlags = toFlag normal,
153
    commandOptions      = \_ -> [optionVerbosity id const]
154 155
  }

156 157 158 159 160 161
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
162
    listSimpleOutput :: Flag Bool,
163 164 165 166 167 168
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
169
    listSimpleOutput = Flag False,
170 171 172 173 174 175 176 177 178
    listVerbosity = toFlag normal
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
    commandSynopsis     = "List available packages on the server (cached).",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "list",
179
    commandDefaultFlags = defaultListFlags,
180
    commandOptions      = \_ -> [
181
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
182

183
        , option [] ["installed"]
184 185 186 187
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

188 189 190 191 192
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

193 194 195 196 197 198 199
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
200
    listSimpleOutput = combine listSimpleOutput,
201 202 203 204
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

205 206 207 208
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

209 210
-- | Install takes the same flags as configure along with a few extras.
--
211
data InstallFlags = InstallFlags {
212
    installDocumentation:: Flag Bool,
213 214 215
    installDryRun       :: Flag Bool,
    installOnly         :: Flag Bool,
    installRootCmd      :: Flag String,
Duncan Coutts's avatar
Duncan Coutts committed
216
    installCabalVersion :: Flag Version,
217
    installLogFile      :: Flag FilePath,
218
    installBuildReports :: Flag Bool,
219
    installSymlinkBinDir:: Flag FilePath
220 221 222 223
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
224
    installDocumentation= Flag False,
225 226 227
    installDryRun       = Flag False,
    installOnly         = Flag False,
    installRootCmd      = mempty,
Duncan Coutts's avatar
Duncan Coutts committed
228
    installCabalVersion = mempty,
229
    installLogFile      = mempty,
230
    installBuildReports = Flag False,
231
    installSymlinkBinDir= mempty
232 233 234
  }

installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)
235
installCommand = configureCommand {
236 237 238 239 240 241 242
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
  commandDefaultFlags = (mempty, defaultInstallFlags),
  commandOptions      = \showOrParseArgs ->
    liftOptionsFst (commandOptions configureCommand showOrParseArgs) ++
    liftOptionsSnd
243 244 245 246 247 248
     ([ option "" ["documentation"]
          "building of documentation"
          installDocumentation (\v flags -> flags { installDocumentation = v })
          (boolOpt [] [])

      , option [] ["dry-run"]
249 250 251
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
252 253 254 255 256 257 258 259 260 261 262 263 264

      , option [] ["root-cmd"]
          "Command used to gain root privileges, when installing with --global."
          installRootCmd (\v flags -> flags { installRootCmd = v })
          (reqArg' "COMMAND" toFlag flagToList)

      , option [] ["cabal-lib-version"]
          ("Select which version of the Cabal lib to use to build packages "
          ++ "(useful for testing).")
          installCabalVersion (\v flags -> flags { installCabalVersion = v })
          (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
                                        (fmap toFlag parse))
                            (map display . flagToList))
Duncan Coutts's avatar
Duncan Coutts committed
265 266 267 268 269 270

      , option [] ["log-builds"]
          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"
          installLogFile (\v flags -> flags { installLogFile = v })
          (reqArg' "FILE" toFlag flagToList)

271 272 273 274 275
      , option [] ["build-reports"]
          "Generate detailed build reports. (overrides --log-builds)"
          installBuildReports (\v flags -> flags { installBuildReports = v })
          trueArg

276 277 278 279 280 281 282 283
      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids
          ParseArgs ->
            option [] ["only"]
              "Only installs the package in the current directory."
              installOnly (\v flags -> flags { installOnly = v })
              trueArg
             : []
          _ -> [])
284 285 286 287 288
  }

instance Monoid InstallFlags where
  mempty = defaultInstallFlags
  mappend a b = InstallFlags {
289
    installDocumentation= combine installDocumentation,
290 291 292
    installDryRun       = combine installDryRun,
    installOnly         = combine installOnly,
    installRootCmd      = combine installRootCmd,
Duncan Coutts's avatar
Duncan Coutts committed
293
    installCabalVersion = combine installCabalVersion,
294
    installLogFile      = combine installLogFile,
295
    installBuildReports = combine installBuildReports,
296
    installSymlinkBinDir= combine installSymlinkBinDir
297 298 299
  }
    where combine field = field a `mappend` field b

300 301 302 303 304 305 306 307 308
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
309
  }
310 311 312 313 314 315 316 317 318 319 320 321 322 323

defaultUploadFlags :: UploadFlags
defaultUploadFlags = UploadFlags {
    uploadCheck     = toFlag False,
    uploadUsername  = mempty,
    uploadPassword  = mempty,
    uploadVerbosity = toFlag normal
  }

uploadCommand :: CommandUI UploadFlags
uploadCommand = CommandUI {
    commandName         = "upload",
    commandSynopsis     = "Uploads source packages to Hackage",
    commandDescription  = Just $ \_ ->
324
         "You can store your Hackage login in the ~/.cabal/config file\n",
325 326 327 328 329
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
330
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
331 332 333 334

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
335
        trueArg
336 337 338 339

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
340 341
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
342 343 344 345

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
346 347
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
      ]
  }

instance Monoid UploadFlags where
  mempty = UploadFlags {
    uploadCheck     = mempty,
    uploadUsername  = mempty,
    uploadPassword  = mempty,
    uploadVerbosity = mempty
  }
  mappend a b = UploadFlags {
    uploadCheck     = combine uploadCheck,
    uploadUsername  = combine uploadUsername,
    uploadPassword  = combine uploadPassword,
    uploadVerbosity = combine uploadVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------

370 371 372
boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt  = Command.boolOpt  flagToMaybe Flag

373
liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]
374 375
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))

376
liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]
377 378
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))

Duncan Coutts's avatar
Duncan Coutts committed
379
usagePackages :: String -> String -> String
380
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
381 382 383 384
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

385 386
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
Duncan Coutts's avatar
Duncan Coutts committed
387 388 389 390 391
parsePackageArgs = parsePkgArgs []
  where
    parsePkgArgs ds [] = Right (reverse ds)
    parsePkgArgs ds (arg:args) =
      case readPToMaybe parseDependencyOrPackageId arg of
392
        Just dep -> parsePkgArgs (dep:ds) args
Duncan Coutts's avatar
Duncan Coutts committed
393
        Nothing  -> Left ("Failed to parse package dependency: " ++ show arg)
394 395 396 397 398 399 400 401 402 403 404

readPToMaybe :: ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str, all isSpace s ]

parseDependencyOrPackageId :: ReadP r Dependency
parseDependencyOrPackageId = parse +++ liftM pkgidToDependency parse
  where
    pkgidToDependency :: PackageIdentifier -> Dependency
    pkgidToDependency p = case packageVersion p of
      Version [] _ -> Dependency (packageName p) AnyVersion
      version      -> Dependency (packageName p) (ThisVersion version)