Setup.hs 13.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
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(..)
Duncan Coutts's avatar
Duncan Coutts committed
24 25

    , parsePackageArgs
26 27
    ) where

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

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

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

Duncan Coutts's avatar
Duncan Coutts committed
58 59 60

globalCommand :: CommandUI Cabal.GlobalFlags
globalCommand = Cabal.globalCommand {
61 62 63 64 65 66 67 68 69
    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
70 71
  }

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

77 78 79 80 81 82 83
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 = [] }


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

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

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

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

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

135 136 137 138 139 140 141 142 143 144
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
    commandSynopsis     = "Check the package for common mistakes",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
    commandDefaultFlags = mempty,
    commandOptions      = mempty
  }

145 146 147 148 149 150
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
151
    listSimpleOutput :: Flag Bool,
152 153 154 155 156 157
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
158
    listSimpleOutput = Flag False,
159 160 161 162 163 164 165 166 167
    listVerbosity = toFlag normal
  }

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

172
        , option [] ["installed"]
173 174 175 176
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

177 178 179 180 181
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

182 183 184 185 186 187 188
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
189
    listSimpleOutput = combine listSimpleOutput,
190 191 192 193
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

194 195 196 197
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

198 199
-- | Install takes the same flags as configure along with a few extras.
--
200
data InstallFlags = InstallFlags {
201
    installDocumentation:: Flag Bool,
202 203 204
    installDryRun       :: Flag Bool,
    installOnly         :: Flag Bool,
    installRootCmd      :: Flag String,
Duncan Coutts's avatar
Duncan Coutts committed
205
    installCabalVersion :: Flag Version,
206
    installLogFile      :: Flag FilePath,
207
    installBuildReports :: Flag Bool,
208
    installSymlinkBinDir:: Flag FilePath
209 210 211 212
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
213
    installDocumentation= Flag False,
214 215 216
    installDryRun       = Flag False,
    installOnly         = Flag False,
    installRootCmd      = mempty,
Duncan Coutts's avatar
Duncan Coutts committed
217
    installCabalVersion = mempty,
218
    installLogFile      = mempty,
219
    installBuildReports = Flag False,
220
    installSymlinkBinDir= mempty
221 222 223
  }

installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)
224
installCommand = configureCommand {
225 226 227 228 229 230 231
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
  commandDefaultFlags = (mempty, defaultInstallFlags),
  commandOptions      = \showOrParseArgs ->
    liftOptionsFst (commandOptions configureCommand showOrParseArgs) ++
    liftOptionsSnd
232 233 234 235 236 237
     ([ option "" ["documentation"]
          "building of documentation"
          installDocumentation (\v flags -> flags { installDocumentation = v })
          (boolOpt [] [])

      , option [] ["dry-run"]
238 239 240
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
241 242 243 244 245 246 247 248 249 250 251 252 253

      , 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
254 255 256 257 258 259

      , 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)

260 261 262 263 264
      , option [] ["build-reports"]
          "Generate detailed build reports. (overrides --log-builds)"
          installBuildReports (\v flags -> flags { installBuildReports = v })
          trueArg

265 266 267 268 269 270 271 272
      ] ++ 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
             : []
          _ -> [])
273 274 275 276 277
  }

instance Monoid InstallFlags where
  mempty = defaultInstallFlags
  mappend a b = InstallFlags {
278
    installDocumentation= combine installDocumentation,
279 280 281
    installDryRun       = combine installDryRun,
    installOnly         = combine installOnly,
    installRootCmd      = combine installRootCmd,
Duncan Coutts's avatar
Duncan Coutts committed
282
    installCabalVersion = combine installCabalVersion,
283
    installLogFile      = combine installLogFile,
284
    installBuildReports = combine installBuildReports,
285
    installSymlinkBinDir= combine installSymlinkBinDir
286 287 288
  }
    where combine field = field a `mappend` field b

289 290 291 292 293 294 295 296 297
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
298
  }
299 300 301 302 303 304 305 306 307 308 309 310 311 312

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 $ \_ ->
313
         "You can store your Hackage login in the ~/.cabal/config file\n",
314 315 316 317 318
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
319
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
320 321 322 323

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
324
        trueArg
325 326 327 328

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
329 330
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
331 332 333 334

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
335 336
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358
      ]
  }

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
-- ------------------------------------------------------------

359 360 361
boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt  = Command.boolOpt  flagToMaybe Flag

362
liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]
363 364
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))

365
liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]
366 367
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))

Duncan Coutts's avatar
Duncan Coutts committed
368
usagePackages :: String -> String -> String
369
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
370 371 372 373
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

374 375
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
Duncan Coutts's avatar
Duncan Coutts committed
376 377 378 379 380
parsePackageArgs = parsePkgArgs []
  where
    parsePkgArgs ds [] = Right (reverse ds)
    parsePkgArgs ds (arg:args) =
      case readPToMaybe parseDependencyOrPackageId arg of
381
        Just dep -> parsePkgArgs (dep:ds) args
Duncan Coutts's avatar
Duncan Coutts committed
382
        Nothing  -> Left ("Failed to parse package dependency: " ++ show arg)
383 384 385 386 387 388 389 390 391 392 393

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)