HcPkg.hs 15 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 14
    HcPkgInfo(..),

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

    -- * Program invocations
27
    initInvocation,
28 29 30 31 32 33
    registerInvocation,
    reregisterInvocation,
    unregisterInvocation,
    exposeInvocation,
    hideInvocation,
    dumpInvocation,
34
    describeInvocation,
35
    listInvocation,
36 37
  ) where

38
import Prelude hiding (init)
39
import Distribution.Package
40
         ( PackageId, ComponentId(..) )
41
import Distribution.InstalledPackageInfo
42
         ( InstalledPackageInfo, InstalledPackageInfo(..)
43 44
         , showInstalledPackageInfo
         , emptyInstalledPackageInfo, fieldsInstalledPackageInfo )
45 46
import Distribution.ParseUtils
import Distribution.Simple.Compiler
47
         ( PackageDB(..), PackageDBStack )
48
import Distribution.Simple.Program.Types
49
         ( ConfiguredProgram(programId) )
50
import Distribution.Simple.Program.Run
51
         ( ProgramInvocation(..), IOEncoding(..), programInvocation
52 53
         , runProgramInvocation, getProgramInvocationOutput )
import Distribution.Text
54
         ( display, simpleParse )
55 56 57
import Distribution.Simple.Utils
         ( die )
import Distribution.Verbosity
Duncan Coutts's avatar
Duncan Coutts committed
58
         ( Verbosity, deafening, silent )
59
import Distribution.Compat.Exception
60
         ( catchIO )
61

62 63
import Data.Char
         ( isSpace )
64 65 66 67 68 69
import Data.List
         ( stripPrefix )
import System.FilePath as FilePath
         ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )
import qualified System.FilePath.Posix as FilePath.Posix

70 71 72 73 74 75 76 77
-- | 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
78 79
  , supportsDirDbs  :: Bool -- ^ supports directory style package databases
  , requiresDirDbs  :: Bool -- ^ requires directory style package databases
80
  }
81

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


-- | Call @hc-pkg@ to unregister a package
--
132
-- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
133
--
134 135
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister hpi verbosity packagedb pkgid =
Duncan Coutts's avatar
Duncan Coutts committed
136
  runProgramInvocation verbosity
137
    (unregisterInvocation hpi verbosity packagedb pkgid)
138 139 140 141


-- | Call @hc-pkg@ to expose a package.
--
142
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
143
--
144 145
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose hpi verbosity packagedb pkgid =
Duncan Coutts's avatar
Duncan Coutts committed
146
  runProgramInvocation verbosity
147
    (exposeInvocation hpi verbosity packagedb pkgid)
148

149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
-- | 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 ++ "'"
164

165
-- | Call @hc-pkg@ to hide a package.
166
--
167
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
168
--
169 170
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide hpi verbosity packagedb pkgid =
Duncan Coutts's avatar
Duncan Coutts committed
171
  runProgramInvocation verbosity
172
    (hideInvocation hpi verbosity packagedb pkgid)
173 174


175 176
-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
177
--
178 179
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump hpi verbosity packagedb = do
180 181

  output <- getProgramInvocationOutput verbosity
182
              (dumpInvocation hpi verbosity packagedb)
183
    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"
184 185 186 187

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

190 191 192 193 194 195 196 197 198
parsePackages :: String -> Either [InstalledPackageInfo] [PError]
parsePackages str =
  let parsed = map parseInstalledPackageInfo' (splitPkgs str)
   in case [ msg | ParseFailed msg <- parsed ] of
        []   -> Left [   setComponentId
                       . maybe id mungePackagePaths (pkgRoot pkg)
                       $ pkg
                     | ParseOk _ pkg <- parsed ]
        msgs -> Right msgs
199
  where
200
    parseInstalledPackageInfo' =
201
      parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
202

203 204 205 206 207 208 209 210 211 212 213 214 215 216
--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
217

218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254
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

255

256
-- Older installed package info files did not have the installedComponentId
257
-- field, so if it is missing then we fill it as the source package ID.
258 259 260
setComponentId :: InstalledPackageInfo -> InstalledPackageInfo
setComponentId pkginfo@InstalledPackageInfo {
                        installedComponentId = ComponentId "",
261 262 263 264 265
                        sourcePackageId    = pkgid
                      }
                    = pkginfo {
                        --TODO use a proper named function for the conversion
                        -- from source package id to installed package id
266
                        installedComponentId = ComponentId (display pkgid)
267
                      }
268
setComponentId pkginfo = pkginfo
269

270

271 272 273 274
-- | 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.
275
-- Note in particular that it does not include the 'ComponentId', just
276 277
-- the source 'PackageId' which is not necessarily unique in any package db.
--
278 279 280
list :: HcPkgInfo -> Verbosity -> PackageDB
     -> IO [PackageId]
list hpi verbosity packagedb = do
281 282

  output <- getProgramInvocationOutput verbosity
283
              (listInvocation hpi verbosity packagedb)
284
    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"
285 286 287 288

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

  where
292
    parsePackageIds = sequence . map simpleParse . words
293

294 295 296 297
--------------------------
-- The program invocations
--

298 299 300
initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation hpi verbosity path =
    programInvocation (hcPkgProgram hpi) args
301 302
  where
    args = ["init", path]
303
        ++ verbosityOpts hpi verbosity
304

305
registerInvocation, reregisterInvocation
306
  :: HcPkgInfo -> Verbosity -> PackageDBStack
307 308 309 310 311
  -> Either FilePath InstalledPackageInfo
  -> ProgramInvocation
registerInvocation   = registerInvocation' "register"
reregisterInvocation = registerInvocation' "update"

312

313
registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack
314 315
                    -> Either FilePath InstalledPackageInfo
                    -> ProgramInvocation
316 317
registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) =
    programInvocation (hcPkgProgram hpi) args
318
  where
319
    args = [cmdname, pkgFile]
320 321 322 323
        ++ (if noPkgDbStack hpi
              then [packageDbOpts hpi (last packagedbs)]
              else packageDbStackOpts hpi packagedbs)
        ++ verbosityOpts hpi verbosity
324

325 326
registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) =
    (programInvocation (hcPkgProgram hpi) args) {
327 328 329 330
      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
      progInvokeInputEncoding = IOEncodingUTF8
    }
  where
331
    args = [cmdname, "-"]
332 333 334 335
        ++ (if noPkgDbStack hpi
              then [packageDbOpts hpi (last packagedbs)]
              else packageDbStackOpts hpi packagedbs)
        ++ verbosityOpts hpi verbosity
336 337


338
unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
Duncan Coutts's avatar
Duncan Coutts committed
339
                     -> ProgramInvocation
340 341 342 343
unregisterInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["unregister", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity
344 345


346 347 348 349 350 351
exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
                 -> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["expose", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity
352

353 354 355 356 357 358 359 360 361
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
362

363 364 365 366 367 368
hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
               -> ProgramInvocation
hideInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["hide", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity
369 370


371 372 373
dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation hpi _verbosity packagedb =
    (programInvocation (hcPkgProgram hpi) args) {
374 375 376
      progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
377 378
    args = ["dump", packageDbOpts hpi packagedb]
        ++ verbosityOpts hpi silent
379 380
           -- We use verbosity level 'silent' because it is important that we
           -- do not contaminate the output with info/debug messages.
381

382 383 384
listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation hpi _verbosity packagedb =
    (programInvocation (hcPkgProgram hpi) args) {
385 386 387
      progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
388 389
    args = ["list", "--simple-output", packageDbOpts hpi packagedb]
        ++ verbosityOpts hpi silent
390 391 392
           -- We use verbosity level 'silent' because it is important that we
           -- do not contaminate the output with info/debug messages.

393

394 395
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts hpi dbstack = case dbstack of
396 397 398 399
  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"
                                       : "--user"
                                       : map specific dbs
  (GlobalPackageDB:dbs)               -> "--global"
400
                                       : ("--no-user-" ++ packageDbFlag hpi)
401 402 403
                                       : map specific dbs
  _                                   -> ierror
  where
404
    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
405
    specific _ = ierror
406
    ierror :: a
407
    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)
408

409 410 411
packageDbFlag :: HcPkgInfo -> String
packageDbFlag hpi
  | flagPackageConf hpi
412 413 414 415
  = "package-conf"
  | otherwise
  = "package-db"

416
packageDbOpts :: HcPkgInfo -> PackageDB -> String
417 418
packageDbOpts _ GlobalPackageDB        = "--global"
packageDbOpts _ UserPackageDB          = "--user"
419
packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
Duncan Coutts's avatar
Duncan Coutts committed
420

421 422 423
verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts hpi v
  | noVerboseFlag hpi
Duncan Coutts's avatar
Duncan Coutts committed
424 425 426 427
                   = []
  | v >= deafening = ["-v2"]
  | v == silent    = ["-v0"]
  | otherwise      = []
428