Commit b9c698ea authored by Christiaan Baaij's avatar Christiaan Baaij
Browse files

Relocatable packages in the same database must share the same prefix

parent 67f608e8
......@@ -61,7 +61,8 @@ import Distribution.Text
import Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import Data.Binary (Binary)
import Data.Binary (Binary)
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
-- -----------------------------------------------------------------------------
......@@ -104,7 +105,8 @@ data InstalledPackageInfo_ m
frameworkDirs :: [FilePath],
frameworks :: [String],
haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath]
haddockHTMLs :: [FilePath],
pkgRoot :: Maybe FilePath
}
deriving (Generic, Read, Show)
......@@ -155,7 +157,8 @@ emptyInstalledPackageInfo
frameworkDirs = [],
frameworks = [],
haddockInterfaces = [],
haddockHTMLs = []
haddockHTMLs = [],
pkgRoot = Nothing
}
noVersion :: Version
......@@ -375,6 +378,9 @@ installedFieldDescrs = [
, listField "haddock-html"
showFilePath parseFilePathQ
haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
, simpleField "pkgroot"
(const Disp.empty) parseFilePathQ
(fromMaybe "" . pkgRoot) (\xs pkg -> pkg{pkgRoot=Just xs})
]
deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo]
......
......@@ -641,7 +641,7 @@ configure (pkg_descr0, pbi) cfg
relocatable = reloc
}
when reloc (checkRelocatable pkg_descr lbi)
when reloc (checkRelocatable verbosity pkg_descr lbi)
let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi
......@@ -1565,14 +1565,16 @@ checkPackageProblems verbosity gpkg pkg = do
else die (intercalate "\n\n" errors)
-- | Preform checks if a relocatable build is allowed
checkRelocatable :: PackageDescription
checkRelocatable :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> IO ()
checkRelocatable pkg lbi = sequence_ [ checkOS
, checkCompiler
, packagePrefixRelative
, depsPrefixRelative
]
checkRelocatable verbosity pkg lbi
= sequence_ [ checkOS
, checkCompiler
, packagePrefixRelative
, depsPrefixRelative
]
where
-- Check if the OS support relocatable builds
checkOS
......@@ -1604,17 +1606,22 @@ checkRelocatable pkg lbi = sequence_ [ checkOS
[ bindir, libdir, dynlibdir, libexecdir, includedir, datadir
, docdir, mandir, htmldir, haddockdir, sysconfdir] )
-- Check if the library dirs of the dependencies are relative to the
-- Check if the library dirs of the dependencies that are in the package
-- database to which the package is installed are relative to the
-- prefix of the package
depsPrefixRelative
= mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))
allDepLibDirs
depsPrefixRelative = do
pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))
mapM_ (doCheck pkgr) ipkgs
where
installDirs = absoluteInstallDirs pkg lbi NoCopyDest
p = prefix installDirs
ipkgs = PackageIndex.allPackages (installedPkgs lbi)
allDepLibDirs = concatMap Installed.libraryDirs ipkgs
msg l = "Library directory of a dependency: " ++ show l ++
"\nis not relative to the installation prefix:\n" ++
show p
doCheck pkgr ipkg
| maybe False (== pkgr) (Installed.pkgRoot ipkg)
= mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))
(Installed.libraryDirs ipkg)
| otherwise
= return ()
installDirs = absoluteInstallDirs pkg lbi NoCopyDest
p = prefix installDirs
ipkgs = PackageIndex.allPackages (installedPkgs lbi)
msg l = "Library directory of a dependency: " ++ show l ++
"\nis not relative to the installation prefix:\n" ++
show p
......@@ -101,5 +101,6 @@ toCurrent ipi@InstalledPackageInfo{} =
Current.frameworkDirs = frameworkDirs ipi,
Current.frameworks = frameworks ipi,
Current.haddockInterfaces = haddockInterfaces ipi,
Current.haddockHTMLs = haddockHTMLs ipi
Current.haddockHTMLs = haddockHTMLs ipi,
Current.pkgRoot = Nothing
}
......@@ -136,5 +136,6 @@ toCurrent ipi@InstalledPackageInfo{} =
Current.frameworkDirs = frameworkDirs ipi,
Current.frameworks = frameworks ipi,
Current.haddockInterfaces = haddockInterfaces ipi,
Current.haddockHTMLs = haddockHTMLs ipi
Current.haddockHTMLs = haddockHTMLs ipi,
Current.pkgRoot = Nothing
}
......@@ -59,8 +59,6 @@ import Distribution.Compat.Exception
import Data.Char
( isSpace )
import Data.Maybe
( fromMaybe )
import Data.List
( stripPrefix )
import System.FilePath as FilePath
......@@ -162,24 +160,13 @@ dump verbosity hcPkg packagedb = do
let parsed = map parseInstalledPackageInfo' (splitPkgs str)
in case [ msg | ParseFailed msg <- parsed ] of
[] -> Left [ setInstalledPackageId
. maybe id mungePackagePaths pkgroot
. maybe id mungePackagePaths (pkgRoot pkg)
$ pkg
| ParseOk _ (pkgroot, pkg) <- parsed ]
| ParseOk _ pkg <- parsed ]
msgs -> Right msgs
parseInstalledPackageInfo' =
parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo)
where
fields = liftFieldFst pkgrootField
: map liftFieldSnd fieldsInstalledPackageInfo
pkgrootField =
simpleField "pkgroot"
showFilePath parseFilePathQ
(fromMaybe "") (\x _ -> Just x)
liftFieldFst = liftField fst (\x (_x,y) -> (x,y))
liftFieldSnd = liftField snd (\y (x,_y) -> (x,y))
parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
--TODO: this could be a lot faster. We're doing normaliseLineEndings twice
-- and converting back and forth with lines/unlines.
......
......@@ -327,7 +327,8 @@ generalInstalledPackageInfo adjustRelIncDirs pkg ipid lib lbi clbi installDirs =
IPI.frameworkDirs = [],
IPI.frameworks = frameworks bi,
IPI.haddockInterfaces = [haddockdir installDirs </> haddockName pkg],
IPI.haddockHTMLs = [htmldir installDirs]
IPI.haddockHTMLs = [htmldir installDirs],
IPI.pkgRoot = Nothing
}
where
bi = libBuildInfo lib
......
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