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
import Distribution.Simple.Program (defaultProgramConfiguration)
Duncan Coutts's avatar
Duncan Coutts committed
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
import Distribution.Simple.Command
import qualified Distribution.Simple.Setup as Cabal
  (GlobalFlags(..),  {-emptyGlobalFlags,-}   globalCommand,
  ConfigFlags(..),   {-emptyConfigFlags,-}   configureCommand,
{-  CopyFlags(..),     emptyCopyFlags,     copyCommand,
  InstallFlags(..),  emptyInstallFlags,  installCommand,
  HaddockFlags(..),  emptyHaddockFlags,  haddockCommand,
  HscolourFlags(..), emptyHscolourFlags, hscolourCommand,
  BuildFlags(..),    emptyBuildFlags,    buildCommand,
  CleanFlags(..),    emptyCleanFlags,    cleanCommand,
  PFEFlags(..),      emptyPFEFlags,      programaticaCommand,
  MakefileFlags(..), emptyMakefileFlags, makefileCommand,
  RegisterFlags(..), emptyRegisterFlags, registerCommand, unregisterCommand,
  SDistFlags(..),    emptySDistFlags,    sdistCommand,
                                         testCommand-})
44
45
import Distribution.Simple.Setup
         ( Flag(..), toFlag, flagToList, trueArg, optionVerbosity )
46
import Distribution.Version
47
         ( Version(Version) )
48
49
import Distribution.Package
         ( Dependency )
50
51
52
53
import Distribution.Text
         ( Text(parse), display )
import Distribution.ReadE
         ( readP_to_E )
54
import Distribution.Verbosity (Verbosity, normal)
55

56
import Distribution.Client.Types
57
         ( Username(..), Password(..) )
58
import Distribution.Client.ParseUtils (readPToMaybe, parseDependencyOrPackageId)
59

60
import Data.Monoid (Monoid(..))
Duncan Coutts's avatar
Duncan Coutts committed
61
62
63

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

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

80
81
82
83
84
85
86
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 = [] }


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

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

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

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

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

138
139
140
141
142
143
144
145
146
147
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
  }

148
149
150
151
152
153
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
154
    listSimpleOutput :: Flag Bool,
155
156
157
158
159
160
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
161
    listSimpleOutput = Flag False,
162
163
164
165
166
167
168
169
170
    listVerbosity = toFlag normal
  }

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

175
        , option [] ["installed"]
176
177
178
179
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

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

185
186
187
188
189
190
191
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
192
    listSimpleOutput = combine listSimpleOutput,
193
194
195
196
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

197
198
199
200
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

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

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

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

      , 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
248
249
250
251
252
253

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

254
255
256
257
258
259
260
261
      ] ++ 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
             : []
          _ -> [])
262
263
264
265
266
  }

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

276
277
278
279
280
281
282
283
284
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
285
  }
286
287
288
289
290
291
292
293
294
295
296
297
298
299

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

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
311
        trueArg
312
313
314
315

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
316
317
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
318
319
320
321

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

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

346
liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]
347
348
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))

349
liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]
350
351
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))

Duncan Coutts's avatar
Duncan Coutts committed
352
usagePackages :: String -> String -> String
353
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
354
355
356
357
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

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