hackport-0.5: cabal/Cabal/Distribution/Simple/Program/HcPkg.hs
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Program.HcPkg
-- Copyright : Duncan Coutts 2009, 2013
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This module provides an library interface to the @hc-pkg@ program.
-- Currently only GHC, GHCJS and LHC have hc-pkg programs.
module Distribution.Simple.Program.HcPkg (
HcPkgInfo(..),
MultiInstance(..),
init,
invoke,
register,
reregister,
registerMultiInstance,
unregister,
recache,
expose,
hide,
dump,
describe,
list,
-- * Program invocations
initInvocation,
registerInvocation,
reregisterInvocation,
registerMultiInstanceInvocation,
unregisterInvocation,
recacheInvocation,
exposeInvocation,
hideInvocation,
dumpInvocation,
describeInvocation,
listInvocation,
) where
import Distribution.Package hiding (installedUnitId)
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
import Prelude hiding (init)
import Data.Char
( isSpace )
import Data.List
( stripPrefix )
import System.FilePath as FilePath
( (</>), (<.>)
, splitPath, splitDirectories, joinPath, isPathSeparator )
import qualified System.FilePath.Posix as FilePath.Posix
-- | 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
, supportsDirDbs :: Bool -- ^ supports directory style package databases
, requiresDirDbs :: Bool -- ^ requires directory style package databases
, nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag
, recacheMultiInstance :: Bool -- ^ supports multi-instance via recache
}
-- | Whether or not use multi-instance functionality.
data MultiInstance = MultiInstance | NoMultiInstance
deriving (Show, Read, Eq, Ord)
-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
--
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)
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()
invoke hpi verbosity dbStack extraArgs =
runProgramInvocation verbosity invocation
where
args = packageDbStackOpts hpi dbStack ++ extraArgs
invocation = programInvocation (hcPkgProgram hpi) args
-- | Call @hc-pkg@ to register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
--
register :: HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath
InstalledPackageInfo
-> IO ()
register hpi verbosity packagedb pkgFile =
runProgramInvocation verbosity
(registerInvocation hpi verbosity packagedb pkgFile)
-- | Call @hc-pkg@ to re-register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
--
reregister :: HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath
InstalledPackageInfo
-> IO ()
reregister hpi verbosity packagedb pkgFile =
runProgramInvocation verbosity
(reregisterInvocation hpi verbosity packagedb pkgFile)
registerMultiInstance :: HcPkgInfo -> Verbosity
-> PackageDBStack
-> InstalledPackageInfo
-> IO ()
registerMultiInstance hpi verbosity packagedbs pkgInfo
| nativeMultiInstance hpi
= runProgramInvocation verbosity
(registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo))
-- 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.
--
| 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
= do let pkgfile = dir </> display (installedUnitId pkgInfo) <.> "conf"
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"
-- | Call @hc-pkg@ to unregister a package
--
-- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
--
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister hpi verbosity packagedb pkgid =
runProgramInvocation verbosity
(unregisterInvocation hpi verbosity packagedb pkgid)
-- | 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)
-- | Call @hc-pkg@ to expose a package.
--
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
--
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose hpi verbosity packagedb pkgid =
runProgramInvocation verbosity
(exposeInvocation hpi verbosity packagedb pkgid)
-- | 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 ++ "'"
-- | Call @hc-pkg@ to hide a package.
--
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
--
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide hpi verbosity packagedb pkgid =
runProgramInvocation verbosity
(hideInvocation hpi verbosity packagedb pkgid)
-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
--
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump hpi verbosity packagedb = do
output <- getProgramInvocationOutput verbosity
(dumpInvocation hpi verbosity packagedb)
`catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"
case parsePackages output of
Left ok -> return ok
_ -> die $ "failed to parse output of '"
++ programId (hcPkgProgram hpi) ++ " dump'"
parsePackages :: String -> Either [InstalledPackageInfo] [PError]
parsePackages str =
let parsed = map parseInstalledPackageInfo' (splitPkgs str)
in case [ msg | ParseFailed msg <- parsed ] of
[] -> Left [ setUnitId
. maybe id mungePackagePaths (pkgRoot pkg)
$ pkg
| ParseOk _ pkg <- parsed ]
msgs -> Right msgs
where
parseInstalledPackageInfo' =
parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
--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
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
-- Older installed package info files did not have the installedUnitId
-- field, so if it is missing then we fill it as the source package ID.
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
setUnitId pkginfo@InstalledPackageInfo {
installedUnitId = SimpleUnitId (ComponentId ""),
sourcePackageId = pkgid
}
= pkginfo {
installedUnitId = mkLegacyUnitId pkgid
}
setUnitId pkginfo = pkginfo
-- | 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.
-- Note in particular that it does not include the 'UnitId', just
-- the source 'PackageId' which is not necessarily unique in any package db.
--
list :: HcPkgInfo -> Verbosity -> PackageDB
-> IO [PackageId]
list hpi verbosity packagedb = do
output <- getProgramInvocationOutput verbosity
(listInvocation hpi verbosity packagedb)
`catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"
case parsePackageIds output of
Just ok -> return ok
_ -> die $ "failed to parse output of '"
++ programId (hcPkgProgram hpi) ++ " list'"
where
parsePackageIds = sequence . map simpleParse . words
--------------------------
-- The program invocations
--
initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation hpi verbosity path =
programInvocation (hcPkgProgram hpi) args
where
args = ["init", path]
++ verbosityOpts hpi verbosity
registerInvocation, reregisterInvocation, registerMultiInstanceInvocation
:: HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
-> ProgramInvocation
registerInvocation = registerInvocation' "register" NoMultiInstance
reregisterInvocation = registerInvocation' "update" NoMultiInstance
registerMultiInstanceInvocation = registerInvocation' "update" MultiInstance
registerInvocation' :: String -> MultiInstance
-> HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
-> ProgramInvocation
registerInvocation' cmdname multiInstance hpi
verbosity packagedbs pkgFileOrInfo =
case pkgFileOrInfo of
Left pkgFile ->
programInvocation (hcPkgProgram hpi) (args pkgFile)
Right pkgInfo ->
(programInvocation (hcPkgProgram hpi) (args "-")) {
progInvokeInput = Just (showInstalledPackageInfo pkgInfo),
progInvokeInputEncoding = IOEncodingUTF8
}
where
args file = [cmdname, file]
++ (if noPkgDbStack hpi
then [packageDbOpts hpi (last packagedbs)]
else packageDbStackOpts hpi packagedbs)
++ [ "--enable-multi-instance" | multiInstance == MultiInstance ]
++ verbosityOpts hpi verbosity
unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
unregisterInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
["unregister", packageDbOpts hpi packagedb, display pkgid]
++ verbosityOpts hpi verbosity
recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB
-> ProgramInvocation
recacheInvocation hpi verbosity packagedb =
programInvocation (hcPkgProgram hpi) $
["recache", packageDbOpts hpi packagedb]
++ verbosityOpts hpi verbosity
exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
["expose", packageDbOpts hpi packagedb, display pkgid]
++ verbosityOpts hpi verbosity
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
hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
hideInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
["hide", packageDbOpts hpi packagedb, display pkgid]
++ verbosityOpts hpi verbosity
dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation hpi _verbosity packagedb =
(programInvocation (hcPkgProgram hpi) args) {
progInvokeOutputEncoding = IOEncodingUTF8
}
where
args = ["dump", packageDbOpts hpi packagedb]
++ verbosityOpts hpi silent
-- We use verbosity level 'silent' because it is important that we
-- do not contaminate the output with info/debug messages.
listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation hpi _verbosity packagedb =
(programInvocation (hcPkgProgram hpi) args) {
progInvokeOutputEncoding = IOEncodingUTF8
}
where
args = ["list", "--simple-output", packageDbOpts hpi packagedb]
++ verbosityOpts hpi silent
-- We use verbosity level 'silent' because it is important that we
-- do not contaminate the output with info/debug messages.
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts hpi dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> "--global"
: "--user"
: map specific dbs
(GlobalPackageDB:dbs) -> "--global"
: ("--no-user-" ++ packageDbFlag hpi)
: map specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
specific _ = ierror
ierror :: a
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
packageDbFlag :: HcPkgInfo -> String
packageDbFlag hpi
| flagPackageConf hpi
= "package-conf"
| otherwise
= "package-db"
packageDbOpts :: HcPkgInfo -> PackageDB -> String
packageDbOpts _ GlobalPackageDB = "--global"
packageDbOpts _ UserPackageDB = "--user"
packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts hpi v
| noVerboseFlag hpi
= []
| v >= deafening = ["-v2"]
| v == silent = ["-v0"]
| otherwise = []