Setup.hs 14.5 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
    installDryRun       :: Flag Bool,
214
    installReinstall    :: Flag Bool,
215
216
    installOnly         :: Flag Bool,
    installRootCmd      :: Flag String,
Duncan Coutts's avatar
Duncan Coutts committed
217
    installCabalVersion :: Flag Version,
218
    installLogFile      :: Flag FilePath,
219
    installBuildReports :: Flag Bool,
220
    installSymlinkBinDir:: Flag FilePath
221
222
223
224
  }

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

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

      , option [] ["dry-run"]
251
252
253
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
254

255
256
257
258
259
      , option [] ["reinstall"]
          "Install even if it means installing the same version again."
          installReinstall (\v flags -> flags { installReinstall = v })
          trueArg

260
261
262
263
264
265
266
267
268
269
270
271
      , 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
272
273
274
275
276
277

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

278
279
280
281
282
      , option [] ["build-reports"]
          "Generate detailed build reports. (overrides --log-builds)"
          installBuildReports (\v flags -> flags { installBuildReports = v })
          trueArg

283
284
285
286
287
288
289
290
      ] ++ 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
             : []
          _ -> [])
291
292
293
294
295
  }

instance Monoid InstallFlags where
  mempty = defaultInstallFlags
  mappend a b = InstallFlags {
296
    installDocumentation= combine installDocumentation,
297
    installDryRun       = combine installDryRun,
298
    installReinstall    = combine installReinstall,
299
300
    installOnly         = combine installOnly,
    installRootCmd      = combine installRootCmd,
Duncan Coutts's avatar
Duncan Coutts committed
301
    installCabalVersion = combine installCabalVersion,
302
    installLogFile      = combine installLogFile,
303
    installBuildReports = combine installBuildReports,
304
    installSymlinkBinDir= combine installSymlinkBinDir
305
306
307
  }
    where combine field = field a `mappend` field b

308
309
310
311
312
313
314
315
316
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
317
  }
318
319
320
321
322
323
324
325
326
327
328
329
330
331

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 $ \_ ->
332
         "You can store your Hackage login in the ~/.cabal/config file\n",
333
334
335
336
337
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
338
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
339
340
341
342

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
343
        trueArg
344
345
346
347

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
348
349
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
350
351
352
353

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
354
355
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
      ]
  }

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

378
379
380
boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt  = Command.boolOpt  flagToMaybe Flag

381
liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]
382
383
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))

384
liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]
385
386
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))

Duncan Coutts's avatar
Duncan Coutts committed
387
usagePackages :: String -> String -> String
388
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
389
390
391
392
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

393
394
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
Duncan Coutts's avatar
Duncan Coutts committed
395
396
397
398
399
parsePackageArgs = parsePkgArgs []
  where
    parsePkgArgs ds [] = Right (reverse ds)
    parsePkgArgs ds (arg:args) =
      case readPToMaybe parseDependencyOrPackageId arg of
400
        Just dep -> parsePkgArgs (dep:ds) args
Duncan Coutts's avatar
Duncan Coutts committed
401
        Nothing  -> Left ("Failed to parse package dependency: " ++ show arg)
402
403
404
405
406
407
408
409
410
411
412

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)