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

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

Duncan Coutts's avatar
Duncan Coutts committed
57 58 59

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

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

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


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

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

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

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

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

134 135 136 137 138 139 140 141 142 143
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
  }

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

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

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

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

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

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

181 182 183 184 185 186 187
        ]
  }

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

193 194 195 196
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

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

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
210 211 212
    installDryRun       = Flag False,
    installOnly         = Flag False,
    installRootCmd      = mempty,
Duncan Coutts's avatar
Duncan Coutts committed
213
    installCabalVersion = mempty,
214 215
    installLogFile      = mempty,
    installSymlinkBinDir= mempty
216 217 218
  }

installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)
219
installCommand = configureCommand {
220 221 222 223 224 225 226
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
  commandDefaultFlags = (mempty, defaultInstallFlags),
  commandOptions      = \showOrParseArgs ->
    liftOptionsFst (commandOptions configureCommand showOrParseArgs) ++
    liftOptionsSnd
227 228 229 230
     ([ option [] ["dry-run"]
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
231 232 233 234 235 236 237 238 239 240 241 242 243

      , 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
244 245 246 247 248 249

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

250 251 252 253 254 255 256 257
      ] ++ 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
             : []
          _ -> [])
258 259 260 261 262
  }

instance Monoid InstallFlags where
  mempty = defaultInstallFlags
  mappend a b = InstallFlags {
263 264 265
    installDryRun       = combine installDryRun,
    installOnly         = combine installOnly,
    installRootCmd      = combine installRootCmd,
Duncan Coutts's avatar
Duncan Coutts committed
266
    installCabalVersion = combine installCabalVersion,
267 268
    installLogFile      = combine installLogFile,
    installSymlinkBinDir= combine installSymlinkBinDir
269 270 271
  }
    where combine field = field a `mappend` field b

272 273 274 275 276 277 278 279 280
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
281
  }
282 283 284 285 286 287 288 289 290 291 292 293 294 295

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 $ \_ ->
296
         "You can store your Hackage login in the ~/.cabal/config file\n",
297 298 299 300 301
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
302
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
303 304 305 306

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
307
        trueArg
308 309 310 311

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
312 313
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
314 315 316 317

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
318 319
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
      ]
  }

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

342
liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]
343 344
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))

345
liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]
346 347
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))

Duncan Coutts's avatar
Duncan Coutts committed
348
usagePackages :: String -> String -> String
349
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
350 351 352 353
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

354 355
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
Duncan Coutts's avatar
Duncan Coutts committed
356 357 358 359 360
parsePackageArgs = parsePkgArgs []
  where
    parsePkgArgs ds [] = Right (reverse ds)
    parsePkgArgs ds (arg:args) =
      case readPToMaybe parseDependencyOrPackageId arg of
361
        Just dep -> parsePkgArgs (dep:ds) args
Duncan Coutts's avatar
Duncan Coutts committed
362
        Nothing  -> Left ("Failed to parse package dependency: " ++ show arg)
363 364 365 366 367 368 369 370 371 372 373

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)