HcPkg.hs 17.5 KB
Newer Older
1
2
3
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Program.HcPkg
4
-- Copyright   :  Duncan Coutts 2009, 2013
5
6
7
8
9
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides an library interface to the @hc-pkg@ program.
10
-- Currently only GHC, GHCJS and LHC have hc-pkg programs.
11
12

module Distribution.Simple.Program.HcPkg (
13
    HcPkgInfo(..),
14
    MultiInstance(..),
15

16
    init,
refold's avatar
refold committed
17
    invoke,
18
19
    register,
    reregister,
20
    registerMultiInstance,
21
    unregister,
22
    recache,
23
24
25
    expose,
    hide,
    dump,
26
    describe,
27
    list,
28
29

    -- * Program invocations
30
    initInvocation,
31
32
    registerInvocation,
    reregisterInvocation,
33
    registerMultiInstanceInvocation,
34
    unregisterInvocation,
35
    recacheInvocation,
36
37
38
    exposeInvocation,
    hideInvocation,
    dumpInvocation,
39
    describeInvocation,
40
    listInvocation,
41
42
  ) where

43
44
45
import Prelude ()
import Distribution.Compat.Prelude hiding (init)

46
import Distribution.Package hiding (installedUnitId)
47
48
49
50
51
52
53
54
55
56
import Distribution.InstalledPackageInfo
import Distribution.ParseUtils
import Distribution.Simple.Compiler
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Run
import Distribution.Text
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Compat.Exception

57
58
59
import Data.List
         ( stripPrefix )
import System.FilePath as FilePath
60
61
         ( (</>), (<.>)
         , splitPath, splitDirectories, joinPath, isPathSeparator )
62
63
import qualified System.FilePath.Posix as FilePath.Posix

64
65
66
67
68
69
70
71
-- | Information about the features and capabilities of an @hc-pkg@
--   program.
--
data HcPkgInfo = HcPkgInfo
  { hcPkgProgram    :: ConfiguredProgram
  , noPkgDbStack    :: Bool -- ^ no package DB stack supported
  , noVerboseFlag   :: Bool -- ^ hc-pkg does not support verbosity flags
  , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db
72
73
  , supportsDirDbs  :: Bool -- ^ supports directory style package databases
  , requiresDirDbs  :: Bool -- ^ requires directory style package databases
74
75
  , nativeMultiInstance  :: Bool -- ^ supports --enable-multi-instance flag
  , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache
76
  }
77

78
79
80
81
-- | Whether or not use multi-instance functionality.
data MultiInstance = MultiInstance | NoMultiInstance
  deriving (Show, Read, Eq, Ord)

82
83
84
85
-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
--
86
87
88
89
90
91
92
93
init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()
init hpi verbosity preferCompat path
  |  not (supportsDirDbs hpi)
 || (not (requiresDirDbs hpi) && preferCompat)
  = writeFile path "[]"

  | otherwise
  = runProgramInvocation verbosity (initInvocation hpi verbosity path)
94

refold's avatar
refold committed
95
96
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
97
98
invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()
invoke hpi verbosity dbStack extraArgs =
refold's avatar
refold committed
99
100
  runProgramInvocation verbosity invocation
  where
101
102
    args       = packageDbStackOpts hpi dbStack ++ extraArgs
    invocation = programInvocation (hcPkgProgram hpi) args
refold's avatar
refold committed
103

104
105
-- | Call @hc-pkg@ to register a package.
--
106
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
107
--
108
register :: HcPkgInfo -> Verbosity -> PackageDBStack
109
110
111
         -> Either FilePath
                   InstalledPackageInfo
         -> IO ()
112
register hpi verbosity packagedb pkgFile =
Duncan Coutts's avatar
Duncan Coutts committed
113
  runProgramInvocation verbosity
114
    (registerInvocation hpi verbosity packagedb pkgFile)
115
116
117
118


-- | Call @hc-pkg@ to re-register a package.
--
119
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
120
--
121
reregister :: HcPkgInfo -> Verbosity -> PackageDBStack
122
123
124
           -> Either FilePath
                     InstalledPackageInfo
           -> IO ()
125
reregister hpi verbosity packagedb pkgFile =
Duncan Coutts's avatar
Duncan Coutts committed
126
  runProgramInvocation verbosity
127
    (reregisterInvocation hpi verbosity packagedb pkgFile)
128

129
130
131
132
133
134
135
136
137
registerMultiInstance :: HcPkgInfo -> Verbosity
                      -> PackageDBStack
                      -> InstalledPackageInfo
                      -> IO ()
registerMultiInstance hpi verbosity packagedbs pkgInfo
  | nativeMultiInstance hpi
  = runProgramInvocation verbosity
      (registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo))

138
139
140
141
142
143
144
145
146
    -- This is a trick. Older versions of GHC do not support the
    -- --enable-multi-instance flag for ghc-pkg register but it turns out that
    -- the same ability is available by using ghc-pkg recache. The recache
    -- command is there to support distro package managers that like to work
    -- by just installing files and running update commands, rather than
    -- special add/remove commands. So the way to register by this method is
    -- to write the package registration file directly into the package db and
    -- then call hc-pkg recache.
    --
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
  | recacheMultiInstance hpi
  = do let pkgdb = last packagedbs
       writeRegistrationFileDirectly hpi pkgdb pkgInfo
       recache hpi verbosity pkgdb

  | otherwise
  = die $ "HcPkg.registerMultiInstance: the compiler does not support "
       ++ "registering multiple instances of packages."

writeRegistrationFileDirectly :: HcPkgInfo
                              -> PackageDB
                              -> InstalledPackageInfo
                              -> IO ()
writeRegistrationFileDirectly hpi (SpecificPackageDB dir) pkgInfo
  | supportsDirDbs hpi
162
  = do let pkgfile = dir </> display (installedUnitId pkgInfo) <.> "conf"
163
164
165
166
167
168
169
170
171
172
       writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)

  | otherwise
  = die $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"

writeRegistrationFileDirectly _ _ _ =
    -- We don't know here what the dir for the global or user dbs are,
    -- if that's needed it'll require a bit more plumbing to support.
    die $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"

173
174
175

-- | Call @hc-pkg@ to unregister a package
--
176
-- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
177
--
178
179
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister hpi verbosity packagedb pkgid =
Duncan Coutts's avatar
Duncan Coutts committed
180
  runProgramInvocation verbosity
181
    (unregisterInvocation hpi verbosity packagedb pkgid)
182
183


184
185
186
187
188
189
190
191
192
193
-- | Call @hc-pkg@ to recache the registered packages.
--
-- > hc-pkg recache [--user | --global | --package-db]
--
recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO ()
recache hpi verbosity packagedb =
  runProgramInvocation verbosity
    (recacheInvocation hpi verbosity packagedb)


194
195
-- | Call @hc-pkg@ to expose a package.
--
196
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
197
--
198
199
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose hpi verbosity packagedb pkgid =
Duncan Coutts's avatar
Duncan Coutts committed
200
  runProgramInvocation verbosity
201
    (exposeInvocation hpi verbosity packagedb pkgid)
202

203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
-- | Call @hc-pkg@ to retrieve a specific package
--
-- > hc-pkg describe [pkgid] [--user | --global | --package-db]
--
describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo]
describe hpi verbosity packagedb pid = do

  output <- getProgramInvocationOutput verbosity
              (describeInvocation hpi verbosity packagedb pid)
    `catchIO` \_ -> return ""

  case parsePackages output of
    Left ok -> return ok
    _       -> die $ "failed to parse output of '"
                  ++ programId (hcPkgProgram hpi) ++ " describe " ++ display pid ++ "'"
218

219
-- | Call @hc-pkg@ to hide a package.
220
--
221
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
222
--
223
224
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide hpi verbosity packagedb pkgid =
Duncan Coutts's avatar
Duncan Coutts committed
225
  runProgramInvocation verbosity
226
    (hideInvocation hpi verbosity packagedb pkgid)
227
228


229
230
-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
231
--
232
233
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump hpi verbosity packagedb = do
234
235

  output <- getProgramInvocationOutput verbosity
236
              (dumpInvocation hpi verbosity packagedb)
237
238
    `catchIO` \e -> die $ programId (hcPkgProgram hpi) ++ " dump failed: "
                       ++ displayException e
239
240
241
242

  case parsePackages output of
    Left ok -> return ok
    _       -> die $ "failed to parse output of '"
243
                  ++ programId (hcPkgProgram hpi) ++ " dump'"
244

245
246
247
248
parsePackages :: String -> Either [InstalledPackageInfo] [PError]
parsePackages str =
  let parsed = map parseInstalledPackageInfo' (splitPkgs str)
   in case [ msg | ParseFailed msg <- parsed ] of
249
        []   -> Left [   setUnitId
250
251
252
253
                       . maybe id mungePackagePaths (pkgRoot pkg)
                       $ pkg
                     | ParseOk _ pkg <- parsed ]
        msgs -> Right msgs
254
  where
255
    parseInstalledPackageInfo' =
256
      parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
257

258
259
260
261
262
263
264
265
266
267
268
269
270
271
--TODO: this could be a lot faster. We're doing normaliseLineEndings twice
-- and converting back and forth with lines/unlines.
splitPkgs :: String -> [String]
splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines
  where
    -- Handle the case of there being no packages at all.
    checkEmpty [s] | all isSpace s = []
    checkEmpty ss                  = ss

    splitWith :: (a -> Bool) -> [a] -> [[a]]
    splitWith p xs = ys : case zs of
                       []   -> []
                       _:ws -> splitWith p ws
      where (ys,zs) = break p xs
272

273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
mungePackagePaths pkgroot pkginfo =
    pkginfo {
      importDirs        = mungePaths (importDirs  pkginfo),
      includeDirs       = mungePaths (includeDirs pkginfo),
      libraryDirs       = mungePaths (libraryDirs pkginfo),
      frameworkDirs     = mungePaths (frameworkDirs pkginfo),
      haddockInterfaces = mungePaths (haddockInterfaces pkginfo),
      haddockHTMLs      = mungeUrls  (haddockHTMLs pkginfo)
    }
  where
    mungePaths = map mungePath
    mungeUrls  = map mungeUrl

    mungePath p = case stripVarPrefix "${pkgroot}" p of
      Just p' -> pkgroot </> p'
      Nothing -> p

    mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of
      Just p' -> toUrlPath pkgroot p'
      Nothing -> p

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
                 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)

    stripVarPrefix var p =
      case splitPath p of
        (root:path') -> case stripPrefix var root of
          Just [sep] | isPathSeparator sep -> Just (joinPath path')
          _                                -> Nothing
        _                                  -> Nothing

310

311
-- Older installed package info files did not have the installedUnitId
312
-- field, so if it is missing then we fill it as the source package ID.
313
314
315
316
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
setUnitId pkginfo@InstalledPackageInfo {
                        installedUnitId = SimpleUnitId (ComponentId ""),
                        sourcePackageId = pkgid
317
318
                      }
                    = pkginfo {
319
                        installedUnitId = mkLegacyUnitId pkgid
320
                      }
321
setUnitId pkginfo = pkginfo
322

323

324
325
326
327
-- | Call @hc-pkg@ to get the source package Id of all the packages in the
-- given package database.
--
-- This is much less information than with 'dump', but also rather quicker.
328
-- Note in particular that it does not include the 'UnitId', just
329
330
-- the source 'PackageId' which is not necessarily unique in any package db.
--
331
332
333
list :: HcPkgInfo -> Verbosity -> PackageDB
     -> IO [PackageId]
list hpi verbosity packagedb = do
334
335

  output <- getProgramInvocationOutput verbosity
336
              (listInvocation hpi verbosity packagedb)
337
    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"
338
339
340
341

  case parsePackageIds output of
    Just ok -> return ok
    _       -> die $ "failed to parse output of '"
342
                  ++ programId (hcPkgProgram hpi) ++ " list'"
343
344

  where
345
    parsePackageIds = traverse simpleParse . words
346

347
348
349
350
--------------------------
-- The program invocations
--

351
352
353
initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation hpi verbosity path =
    programInvocation (hcPkgProgram hpi) args
354
355
  where
    args = ["init", path]
356
        ++ verbosityOpts hpi verbosity
357

358
registerInvocation, reregisterInvocation, registerMultiInstanceInvocation
359
  :: HcPkgInfo -> Verbosity -> PackageDBStack
360
361
  -> Either FilePath InstalledPackageInfo
  -> ProgramInvocation
362
363
364
registerInvocation   = registerInvocation' "register" NoMultiInstance
reregisterInvocation = registerInvocation' "update"   NoMultiInstance
registerMultiInstanceInvocation = registerInvocation' "update" MultiInstance
365

366
registerInvocation' :: String -> MultiInstance
367
                    -> HcPkgInfo -> Verbosity -> PackageDBStack
368
369
                    -> Either FilePath InstalledPackageInfo
                    -> ProgramInvocation
370
371
registerInvocation' cmdname multiInstance hpi
                    verbosity packagedbs pkgFileOrInfo =
372
373
374
375
376
377
378
379
380
    case pkgFileOrInfo of
      Left pkgFile ->
        programInvocation (hcPkgProgram hpi) (args pkgFile)

      Right pkgInfo ->
        (programInvocation (hcPkgProgram hpi) (args "-")) {
          progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
          progInvokeInputEncoding = IOEncodingUTF8
        }
381
  where
382
383
384
385
    args file = [cmdname, file]
             ++ (if noPkgDbStack hpi
                   then [packageDbOpts hpi (last packagedbs)]
                   else packageDbStackOpts hpi packagedbs)
386
             ++ [ "--enable-multi-instance" | multiInstance == MultiInstance ]
387
             ++ verbosityOpts hpi verbosity
388

389
unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
Duncan Coutts's avatar
Duncan Coutts committed
390
                     -> ProgramInvocation
391
392
393
394
unregisterInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["unregister", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity
395
396


397
398
399
400
401
402
403
404
recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB
                  -> ProgramInvocation
recacheInvocation hpi verbosity packagedb =
  programInvocation (hcPkgProgram hpi) $
       ["recache", packageDbOpts hpi packagedb]
    ++ verbosityOpts hpi verbosity


405
406
407
408
409
410
exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
                 -> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["expose", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity
411

412
413
414
415
416
417
418
419
420
describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId
                   -> ProgramInvocation
describeInvocation hpi verbosity packagedbs pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["describe", display pkgid]
    ++ (if noPkgDbStack hpi
          then [packageDbOpts hpi (last packagedbs)]
          else packageDbStackOpts hpi packagedbs)
    ++ verbosityOpts hpi verbosity
421

422
423
424
425
426
427
hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
               -> ProgramInvocation
hideInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["hide", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity
428
429


430
431
432
dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation hpi _verbosity packagedb =
    (programInvocation (hcPkgProgram hpi) args) {
433
434
435
      progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
436
437
    args = ["dump", packageDbOpts hpi packagedb]
        ++ verbosityOpts hpi silent
438
439
           -- We use verbosity level 'silent' because it is important that we
           -- do not contaminate the output with info/debug messages.
440

441
442
443
listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation hpi _verbosity packagedb =
    (programInvocation (hcPkgProgram hpi) args) {
444
445
446
      progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
447
448
    args = ["list", "--simple-output", packageDbOpts hpi packagedb]
        ++ verbosityOpts hpi silent
449
450
451
           -- We use verbosity level 'silent' because it is important that we
           -- do not contaminate the output with info/debug messages.

452

453
454
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts hpi dbstack = case dbstack of
455
456
457
458
  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"
                                       : "--user"
                                       : map specific dbs
  (GlobalPackageDB:dbs)               -> "--global"
459
                                       : ("--no-user-" ++ packageDbFlag hpi)
460
461
462
                                       : map specific dbs
  _                                   -> ierror
  where
463
    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
464
    specific _ = ierror
simonpj's avatar
simonpj committed
465
    ierror :: a
466
    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)
467

468
469
470
packageDbFlag :: HcPkgInfo -> String
packageDbFlag hpi
  | flagPackageConf hpi
471
472
473
474
  = "package-conf"
  | otherwise
  = "package-db"

475
packageDbOpts :: HcPkgInfo -> PackageDB -> String
476
477
packageDbOpts _ GlobalPackageDB        = "--global"
packageDbOpts _ UserPackageDB          = "--user"
478
packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
Duncan Coutts's avatar
Duncan Coutts committed
479

480
481
482
verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts hpi v
  | noVerboseFlag hpi
Duncan Coutts's avatar
Duncan Coutts committed
483
484
485
486
                   = []
  | v >= deafening = ["-v2"]
  | v == silent    = ["-v0"]
  | otherwise      = []
487