Cabal-1.22.1.0: 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(..),
init,
invoke,
register,
reregister,
unregister,
expose,
hide,
dump,
list,
-- * Program invocations
initInvocation,
registerInvocation,
reregisterInvocation,
unregisterInvocation,
exposeInvocation,
hideInvocation,
dumpInvocation,
listInvocation,
) where
import Prelude hiding (init)
import Distribution.Package
( PackageId, InstalledPackageId(..) )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo, InstalledPackageInfo_(..)
, showInstalledPackageInfo
, emptyInstalledPackageInfo, fieldsInstalledPackageInfo )
import Distribution.ParseUtils
import Distribution.Simple.Compiler
( PackageDB(..), PackageDBStack )
import Distribution.Simple.Program.Types
( ConfiguredProgram(programId) )
import Distribution.Simple.Program.Run
( ProgramInvocation(..), IOEncoding(..), programInvocation
, runProgramInvocation, getProgramInvocationOutput )
import Distribution.Text
( display, simpleParse )
import Distribution.Simple.Utils
( die )
import Distribution.Verbosity
( Verbosity, deafening, silent )
import Distribution.Compat.Exception
( catchExit )
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
, useSingleFileDb :: Bool -- ^ requires single file package database
}
-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
--
init :: HcPkgInfo -> Verbosity -> FilePath -> IO ()
init hpi verbosity path =
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)
-- | 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 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 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)
`catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"
case parsePackages output of
Left ok -> return ok
_ -> die $ "failed to parse output of '"
++ programId (hcPkgProgram hpi) ++ " dump'"
where
parsePackages str =
let parsed = map parseInstalledPackageInfo' (splitPkgs str)
in case [ msg | ParseFailed msg <- parsed ] of
[] -> Left [ setInstalledPackageId
. maybe id mungePackagePaths (pkgRoot pkg)
$ pkg
| ParseOk _ pkg <- parsed ]
msgs -> Right msgs
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 installedPackageId
-- field, so if it is missing then we fill it as the source package ID.
setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo
setInstalledPackageId pkginfo@InstalledPackageInfo {
installedPackageId = InstalledPackageId "",
sourcePackageId = pkgid
}
= pkginfo {
--TODO use a proper named function for the conversion
-- from source package id to installed package id
installedPackageId = InstalledPackageId (display pkgid)
}
setInstalledPackageId 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 'InstalledPackageId', 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)
`catchExit` \_ -> 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
:: HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
-> ProgramInvocation
registerInvocation = registerInvocation' "register"
reregisterInvocation = registerInvocation' "update"
registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
-> ProgramInvocation
registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) =
programInvocation (hcPkgProgram hpi) args
where
args = [cmdname, pkgFile]
++ (if noPkgDbStack hpi
then [packageDbOpts hpi (last packagedbs)]
else packageDbStackOpts hpi packagedbs)
++ verbosityOpts hpi verbosity
registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) =
(programInvocation (hcPkgProgram hpi) args) {
progInvokeInput = Just (showInstalledPackageInfo pkgInfo),
progInvokeInputEncoding = IOEncodingUTF8
}
where
args = [cmdname, "-"]
++ (if noPkgDbStack hpi
then [packageDbOpts hpi (last packagedbs)]
else packageDbStackOpts hpi packagedbs)
++ 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
exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
["expose", packageDbOpts hpi packagedb, display pkgid]
++ 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 = []