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/ ...@@ -11,6 +11,7 @@ cabal-dev/
cabal.config cabal.config
dist dist
dist-* dist-*
register.sh
/Cabal/dist/ /Cabal/dist/
/Cabal/tests/Setup /Cabal/tests/Setup
......
...@@ -146,6 +146,8 @@ extra-source-files: ...@@ -146,6 +146,8 @@ extra-source-files:
tests/PackageTests/InternalLibraries/p/q/Q.hs tests/PackageTests/InternalLibraries/p/q/Q.hs
tests/PackageTests/InternalLibraries/q/Q.hs tests/PackageTests/InternalLibraries/q/Q.hs
tests/PackageTests/InternalLibraries/q/q.cabal 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/A.hs
tests/PackageTests/Macros/B.hs tests/PackageTests/Macros/B.hs
tests/PackageTests/Macros/Main.hs tests/PackageTests/Macros/Main.hs
......
...@@ -465,12 +465,10 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath ...@@ -465,12 +465,10 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath
createInternalPackageDB verbosity lbi distPref = do createInternalPackageDB verbosity lbi distPref = do
existsAlready <- doesPackageDBExist dbPath existsAlready <- doesPackageDBExist dbPath
when existsAlready $ deletePackageDB dbPath when existsAlready $ deletePackageDB dbPath
createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
return (SpecificPackageDB dbPath) return (SpecificPackageDB dbPath)
where where
dbPath = case compilerFlavor (compiler lbi) of dbPath = internalPackageDBPath lbi distPref
UHC -> UHC.inplacePackageDbPath lbi
_ -> distPref </> "package.conf.inplace"
addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
-> ProgramDb -> ProgramDb -> ProgramDb -> ProgramDb
......
{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Distribution.Simple.Register -- Module : Distribution.Simple.Register
...@@ -27,6 +28,8 @@ module Distribution.Simple.Register ( ...@@ -27,6 +28,8 @@ module Distribution.Simple.Register (
register, register,
unregister, unregister,
internalPackageDBPath,
initPackageDB, initPackageDB,
doesPackageDBExist, doesPackageDBExist,
createPackageDB, createPackageDB,
...@@ -65,15 +68,11 @@ import Distribution.Verbosity as Verbosity ...@@ -65,15 +68,11 @@ import Distribution.Verbosity as Verbosity
import System.FilePath ((</>), (<.>), isAbsolute) import System.FilePath ((</>), (<.>), isAbsolute)
import System.Directory import System.Directory
( getCurrentDirectory, removeDirectoryRecursive, removeFile
, doesDirectoryExist, doesFileExist )
import Data.Version import Data.Version
import Control.Monad (when) import Control.Monad
import Data.Maybe import Data.Maybe
( isJust, fromMaybe, maybeToList )
import Data.List import Data.List
( partition, nub )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
...@@ -87,38 +86,60 @@ register pkg lbi regFlags = ...@@ -87,38 +86,60 @@ register pkg lbi regFlags =
-- if there is no public library, since no one else can use it -- if there is no public library, since no one else can use it
-- usefully (they're not public.) If we start supporting scoped -- usefully (they're not public.) If we start supporting scoped
-- packages, we'll have to relax this. -- packages, we'll have to relax this.
when (hasPublicLib pkg) $ when (hasPublicLib pkg) $ do
let maybeRegister (CLib lib) _clbi = -- It's important to register in build order, because ghc-pkg
registerOne pkg lbi regFlags lib -- will complain if a dependency is not registered.
maybeRegister _comp _clbi = return () let maybeGenerateOne clbi
in withAllComponentsInBuildOrder pkg lbi maybeRegister | CLib lib <- getLocalComponent pkg clbi
= fmap Just (generateOne pkg lib lbi clbi regFlags)
registerOne :: PackageDescription -> LocalBuildInfo -> RegisterFlags | otherwise = return Nothing
-> Library ipis <- fmap catMaybes
-> IO () $ mapM maybeGenerateOne (allComponentsInBuildOrder lbi)
registerOne pkg lbi regFlags lib registerAll pkg lbi regFlags ipis
return ()
generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo
-> RegisterFlags
-> IO InstalledPackageInfo
generateOne pkg lib lbi clbi regFlags
= do = do
let clbi = getComponentLocalBuildInfo lbi (CLibName (libName lib))
absPackageDBs <- absolutePackageDBPaths packageDbs absPackageDBs <- absolutePackageDBPaths packageDbs
-- TODO: registration info named base on LIBNAME!!!
installedPkgInfo <- generateRegistrationInfo installedPkgInfo <- generateRegistrationInfo
verbosity pkg lib lbi clbi inplace reloc distPref verbosity pkg lib lbi clbi inplace reloc distPref
(registrationPackageDB absPackageDBs) (registrationPackageDB absPackageDBs)
info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) 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 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: -- Three different modes:
case () of case () of
_ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory
| modeGenerateRegScript -> writeRegisterScript installedPkgInfo | modeGenerateRegScript -> writeRegisterScript
| otherwise -> do | otherwise -> do
setupMessage verbosity "Registering" (packageId pkg) setupMessage verbosity "Registering" (packageId pkg)
registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.NoMultiInstance forM_ ipis $ \installedPkgInfo ->
packageDbs installedPkgInfo registerPackage verbosity (compiler lbi) (withPrograms lbi)
HcPkg.NoMultiInstance packageDbs installedPkgInfo
where where
modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
...@@ -127,28 +148,40 @@ registerOne pkg lbi regFlags lib ...@@ -127,28 +148,40 @@ registerOne pkg lbi regFlags lib
modeGenerateRegScript = fromFlag (regGenScript regFlags) modeGenerateRegScript = fromFlag (regGenScript regFlags)
inplace = fromFlag (regInPlace regFlags)
reloc = relocatable lbi
-- FIXME: there's really no guarantee this will work. -- FIXME: there's really no guarantee this will work.
-- registering into a totally different db stack can -- registering into a totally different db stack can
-- fail if dependencies cannot be satisfied. -- fail if dependencies cannot be satisfied.
packageDbs = nub $ withPackageDB lbi packageDbs = nub $ withPackageDB lbi
++ maybeToList (flagToMaybe (regPackageDB regFlags)) ++ maybeToList (flagToMaybe (regPackageDB regFlags))
distPref = fromFlag (regDistPref regFlags)
verbosity = fromFlag (regVerbosity regFlags) verbosity = fromFlag (regVerbosity regFlags)
writeRegistrationFile installedPkgInfo = do writeRegistrationFileOrDirectory = do
notice verbosity ("Creating package registration file: " ++ regFile) -- Handles overwriting both directory and file
writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo) deletePackageDB regFile
case ipis of
writeRegisterScript installedPkgInfo = [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 case compilerFlavor (compiler lbi) of
JHC -> notice verbosity "Registration scripts not needed for jhc" JHC -> notice verbosity "Registration scripts not needed for jhc"
UHC -> notice verbosity "Registration scripts not needed for uhc" UHC -> notice verbosity "Registration scripts not needed for uhc"
_ -> withHcPkg _ -> withHcPkg
"Registration scripts are not implemented for this compiler" "Registration scripts are not implemented for this compiler"
(compiler lbi) (withPrograms lbi) (compiler lbi) (withPrograms lbi)
(writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs) (writeHcPkgRegisterScript verbosity ipis packageDbs)
generateRegistrationInfo :: Verbosity generateRegistrationInfo :: Verbosity
...@@ -168,12 +201,16 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packa ...@@ -168,12 +201,16 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packa
--TODO: the method of setting the UnitId is compiler specific --TODO: the method of setting the UnitId is compiler specific
-- this aspect should be delegated to a per-compiler helper. -- this aspect should be delegated to a per-compiler helper.
let comp = compiler lbi let comp = compiler lbi
lbi' = lbi {
withPackageDB = withPackageDB lbi
++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]
}
abi_hash <- abi_hash <-
case compilerFlavor comp of case compilerFlavor comp of
GHC | compilerVersion comp >= Version [6,11] [] -> do 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 GHCJS -> do
fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi lib clbi fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi
_ -> return (AbiHash "") _ -> return (AbiHash "")
installedPkgInfo <- installedPkgInfo <-
...@@ -278,14 +315,18 @@ registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo ...@@ -278,14 +315,18 @@ registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo
_ -> die "Registering is not implemented for this compiler" _ -> die "Registering is not implemented for this compiler"
writeHcPkgRegisterScript :: Verbosity writeHcPkgRegisterScript :: Verbosity
-> InstalledPackageInfo -> [InstalledPackageInfo]
-> PackageDBStack -> PackageDBStack
-> HcPkg.HcPkgInfo -> HcPkg.HcPkgInfo
-> IO () -> IO ()
writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do
let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal let genScript installedPkgInfo =
packageDbs (Right installedPkgInfo) let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal
regScript = invocationAsSystemScript buildOS invocation 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) notice verbosity ("Creating package registration script: " ++ regScriptFileName)
writeUTF8File regScriptFileName regScript writeUTF8File regScriptFileName regScript
...@@ -469,3 +510,9 @@ unregScriptFileName :: FilePath ...@@ -469,3 +510,9 @@ unregScriptFileName :: FilePath
unregScriptFileName = case buildOS of unregScriptFileName = case buildOS of
Windows -> "unregister.bat" Windows -> "unregister.bat"
_ -> "unregister.sh" _ -> "unregister.sh"
internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath
internalPackageDBPath lbi distPref =
case compilerFlavor (compiler lbi) of
UHC -> UHC.inplacePackageDbPath lbi
_ -> distPref </> "package.conf.inplace"
module P where module P where
import Q import Q
p = "P: " ++ q
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 ...@@ -14,6 +14,7 @@ import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.InstallDirs ( CopyDest(NoCopyDest) ) import Distribution.Simple.InstallDirs ( CopyDest(NoCopyDest) )
import Distribution.Simple.BuildPaths ( mkLibName, mkSharedLibName ) import Distribution.Simple.BuildPaths ( mkLibName, mkSharedLibName )
import Distribution.Simple.Compiler ( compilerId ) import Distribution.Simple.Compiler ( compilerId )
import Distribution.System (buildOS, OS(Windows))
import Control.Monad import Control.Monad
...@@ -301,6 +302,39 @@ tests config = do ...@@ -301,6 +302,39 @@ tests config = do
r <- runInstalledExe' "foo" [] r <- runInstalledExe' "foo" []
assertOutputContains "I AM THE ONE" r 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: -- Internal libraries used by a statically linked executable:
-- no libraries should get installed or registered. (Note, -- no libraries should get installed or registered. (Note,
-- this does build shared libraries just to make sure they -- 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