Commit b8d30ee2 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Properly handle --gen-pkg-config and --gen-script flags with internal libraries.



Additionally, ABI computation no longer requires successful
registration, so you can generate scripts in any order.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 375574a0
......@@ -11,6 +11,7 @@ cabal-dev/
cabal.config
dist
dist-*
register.sh
/Cabal/dist/
/Cabal/tests/Setup
......
......@@ -146,6 +146,8 @@ extra-source-files:
tests/PackageTests/InternalLibraries/p/q/Q.hs
tests/PackageTests/InternalLibraries/q/Q.hs
tests/PackageTests/InternalLibraries/q/q.cabal
tests/PackageTests/InternalLibraries/r/R.hs
tests/PackageTests/InternalLibraries/r/r.cabal
tests/PackageTests/Macros/A.hs
tests/PackageTests/Macros/B.hs
tests/PackageTests/Macros/Main.hs
......
......@@ -465,12 +465,10 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath
createInternalPackageDB verbosity lbi distPref = do
existsAlready <- doesPackageDBExist dbPath
when existsAlready $ deletePackageDB dbPath
createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
return (SpecificPackageDB dbPath)
where
dbPath = case compilerFlavor (compiler lbi) of
UHC -> UHC.inplacePackageDbPath lbi
_ -> distPref </> "package.conf.inplace"
dbPath = internalPackageDBPath lbi distPref
addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
-> ProgramDb -> ProgramDb
......
{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Register
......@@ -27,6 +28,8 @@ module Distribution.Simple.Register (
register,
unregister,
internalPackageDBPath,
initPackageDB,
doesPackageDBExist,
createPackageDB,
......@@ -65,15 +68,11 @@ import Distribution.Verbosity as Verbosity
import System.FilePath ((</>), (<.>), isAbsolute)
import System.Directory
( getCurrentDirectory, removeDirectoryRecursive, removeFile
, doesDirectoryExist, doesFileExist )
import Data.Version
import Control.Monad (when)
import Control.Monad
import Data.Maybe
( isJust, fromMaybe, maybeToList )
import Data.List
( partition, nub )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- -----------------------------------------------------------------------------
......@@ -87,38 +86,60 @@ register pkg lbi regFlags =
-- if there is no public library, since no one else can use it
-- usefully (they're not public.) If we start supporting scoped
-- packages, we'll have to relax this.
when (hasPublicLib pkg) $
let maybeRegister (CLib lib) _clbi =
registerOne pkg lbi regFlags lib
maybeRegister _comp _clbi = return ()
in withAllComponentsInBuildOrder pkg lbi maybeRegister
registerOne :: PackageDescription -> LocalBuildInfo -> RegisterFlags
-> Library
-> IO ()
registerOne pkg lbi regFlags lib
when (hasPublicLib pkg) $ do
-- It's important to register in build order, because ghc-pkg
-- will complain if a dependency is not registered.
let maybeGenerateOne clbi
| CLib lib <- getLocalComponent pkg clbi
= fmap Just (generateOne pkg lib lbi clbi regFlags)
| otherwise = return Nothing
ipis <- fmap catMaybes
$ mapM maybeGenerateOne (allComponentsInBuildOrder lbi)
registerAll pkg lbi regFlags ipis
return ()
generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo
-> RegisterFlags
-> IO InstalledPackageInfo
generateOne pkg lib lbi clbi regFlags
= do
let clbi = getComponentLocalBuildInfo lbi (CLibName (libName lib))
absPackageDBs <- absolutePackageDBPaths packageDbs
-- TODO: registration info named base on LIBNAME!!!
installedPkgInfo <- generateRegistrationInfo
verbosity pkg lib lbi clbi inplace reloc distPref
(registrationPackageDB absPackageDBs)
info verbosity (IPI.showInstalledPackageInfo installedPkgInfo)
return installedPkgInfo
where
inplace = fromFlag (regInPlace regFlags)
reloc = relocatable lbi
-- FIXME: there's really no guarantee this will work.
-- registering into a totally different db stack can
-- fail if dependencies cannot be satisfied.
packageDbs = nub $ withPackageDB lbi
++ maybeToList (flagToMaybe (regPackageDB regFlags))
distPref = fromFlag (regDistPref regFlags)
verbosity = fromFlag (regVerbosity regFlags)
registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags
-> [InstalledPackageInfo]
-> IO ()
registerAll pkg lbi regFlags ipis
= do
when (fromFlag (regPrintId regFlags)) $ do
putStrLn (display (IPI.installedUnitId installedPkgInfo))
forM_ ipis $ \installedPkgInfo ->
-- Only print the public library's IPI
when (IPI.sourcePackageId installedPkgInfo == packageId pkg) $
putStrLn (display (IPI.installedUnitId installedPkgInfo))
-- Three different modes:
case () of
_ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo
| modeGenerateRegScript -> writeRegisterScript installedPkgInfo
_ | modeGenerateRegFile -> writeRegistrationFileOrDirectory
| modeGenerateRegScript -> writeRegisterScript
| otherwise -> do
setupMessage verbosity "Registering" (packageId pkg)
registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.NoMultiInstance
packageDbs installedPkgInfo
forM_ ipis $ \installedPkgInfo ->
registerPackage verbosity (compiler lbi) (withPrograms lbi)
HcPkg.NoMultiInstance packageDbs installedPkgInfo
where
modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
......@@ -127,28 +148,40 @@ registerOne pkg lbi regFlags lib
modeGenerateRegScript = fromFlag (regGenScript regFlags)
inplace = fromFlag (regInPlace regFlags)
reloc = relocatable lbi
-- FIXME: there's really no guarantee this will work.
-- registering into a totally different db stack can
-- fail if dependencies cannot be satisfied.
packageDbs = nub $ withPackageDB lbi
++ maybeToList (flagToMaybe (regPackageDB regFlags))
distPref = fromFlag (regDistPref regFlags)
verbosity = fromFlag (regVerbosity regFlags)
writeRegistrationFile installedPkgInfo = do
notice verbosity ("Creating package registration file: " ++ regFile)
writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)
writeRegisterScript installedPkgInfo =
writeRegistrationFileOrDirectory = do
-- Handles overwriting both directory and file
deletePackageDB regFile
case ipis of
[installedPkgInfo] -> do
notice verbosity ("Creating package registration file: " ++ regFile)
writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)
_ -> do
notice verbosity ("Creating package registration directory: " ++ regFile)
createDirectory regFile
let num_ipis = length ipis
lpad m xs = replicate (m - length ys) '0' ++ ys
where ys = take m xs
number i = lpad (length (show num_ipis)) (show i)
forM_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->
-- TODO: This will need a hashUnitId when Backpack comes.
writeUTF8File (regFile </> (number i ++ "-" ++ display (IPI.installedUnitId installedPkgInfo)))
(IPI.showInstalledPackageInfo installedPkgInfo)
writeRegisterScript =
case compilerFlavor (compiler lbi) of
JHC -> notice verbosity "Registration scripts not needed for jhc"
UHC -> notice verbosity "Registration scripts not needed for uhc"
_ -> withHcPkg
"Registration scripts are not implemented for this compiler"
(compiler lbi) (withPrograms lbi)
(writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs)
(writeHcPkgRegisterScript verbosity ipis packageDbs)
generateRegistrationInfo :: Verbosity
......@@ -168,12 +201,16 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packa
--TODO: the method of setting the UnitId is compiler specific
-- this aspect should be delegated to a per-compiler helper.
let comp = compiler lbi
lbi' = lbi {
withPackageDB = withPackageDB lbi
++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]
}
abi_hash <-
case compilerFlavor comp of
GHC | compilerVersion comp >= Version [6,11] [] -> do
fmap AbiHash $ GHC.libAbiHash verbosity pkg lbi lib clbi
fmap AbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi
GHCJS -> do
fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi lib clbi
fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi
_ -> return (AbiHash "")
installedPkgInfo <-
......@@ -278,14 +315,18 @@ registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo
_ -> die "Registering is not implemented for this compiler"
writeHcPkgRegisterScript :: Verbosity
-> InstalledPackageInfo
-> [InstalledPackageInfo]
-> PackageDBStack
-> HcPkg.HcPkgInfo
-> IO ()
writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do
let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal
packageDbs (Right installedPkgInfo)
regScript = invocationAsSystemScript buildOS invocation
writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do
let genScript installedPkgInfo =
let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal
packageDbs (Right installedPkgInfo)
in invocationAsSystemScript buildOS invocation
scripts = map genScript ipis
-- TODO: Do something more robust here
regScript = unlines scripts
notice verbosity ("Creating package registration script: " ++ regScriptFileName)
writeUTF8File regScriptFileName regScript
......@@ -469,3 +510,9 @@ unregScriptFileName :: FilePath
unregScriptFileName = case buildOS of
Windows -> "unregister.bat"
_ -> "unregister.sh"
internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath
internalPackageDBPath lbi distPref =
case compilerFlavor (compiler lbi) of
UHC -> UHC.inplacePackageDbPath lbi
_ -> distPref </> "package.conf.inplace"
module R where
import P
r = "R: " ++ p
name: r
version: 0.1.0.0
license: BSD3
author: Edward Z. Yang
maintainer: ezyang@cs.stanford.edu
build-type: Simple
cabal-version: >=1.10
library
exposed-modules: R
build-depends: base, p
default-language: Haskell2010
......@@ -14,6 +14,7 @@ import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.InstallDirs ( CopyDest(NoCopyDest) )
import Distribution.Simple.BuildPaths ( mkLibName, mkSharedLibName )
import Distribution.Simple.Compiler ( compilerId )
import Distribution.System (buildOS, OS(Windows))
import Control.Monad
......@@ -301,6 +302,39 @@ tests config = do
r <- runInstalledExe' "foo" []
assertOutputContains "I AM THE ONE" r
-- Test to see if --gen-script works.
tcs "InternalLibraries" "gen-script" $ do
withPackageDb $ do
withPackage "p" $ do
cabal_build []
cabal "copy" []
cabal "register" ["--gen-script"]
_ <- if buildOS == Windows
then shell "cmd" ["/C", "register.bat"]
else shell "./register.sh" []
return ()
-- Make sure we can see p
withPackage "r" $ cabal_install []
-- Test to see if --gen-pkg-config works.
tcs "InternalLibraries" "gen-pkg-config" $ do
withPackageDb $ do
withPackage "p" $ do
cabal_build []
cabal "copy" []
let dir = "pkg-config.bak"
cabal "register" ["--gen-pkg-config=" ++ dir]
-- Infelicity! Does not respect CWD.
pkg_dir <- packageDir
let notHidden = not . isHidden
isHidden name = "." `isPrefixOf` name
confs <- fmap (sort . filter notHidden)
. liftIO $ getDirectoryContents (pkg_dir </> dir)
forM_ confs $ \conf -> ghcPkg "register" [pkg_dir </> dir </> conf]
-- Make sure we can see p
withPackage "r" $ cabal_install []
-- Internal libraries used by a statically linked executable:
-- no libraries should get installed or registered. (Note,
-- this does build shared libraries just to make sure they
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment