Commit 717cf359 authored by Christiaan Baaij's avatar Christiaan Baaij
Browse files

Correctly calculate relative paths for relocatable packages

parent a1328251
......@@ -62,14 +62,13 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
, LibraryName(..), absoluteInstallDirs, prefixRelativeInstallDirs )
, LibraryName(..), absoluteInstallDirs )
import qualified Distribution.Simple.Hpc as Hpc
import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs,
prefixRelativeInstallDirs )
import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Package
( PackageName(..), Package(..), InstalledPackageId, PackageId )
( PackageName(..), InstalledPackageId, PackageId )
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
( Program(..), ConfiguredProgram(..), ProgramConfiguration
......@@ -94,7 +93,7 @@ import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion
, OptimisationLevel(..), PackageDB(..), PackageDBStack, AbiTag(..)
, Flag, packageKeySupported )
, Flag )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion )
import Distribution.System
......@@ -111,13 +110,13 @@ import Control.Monad ( unless, when )
import Data.Char ( isDigit, isSpace )
import Data.List
import qualified Data.Map as M ( Map, fromList, lookup )
import Data.Maybe ( catMaybes, fromJust, fromMaybe, maybeToList )
import Data.Maybe ( catMaybes, fromMaybe, maybeToList )
import Data.Monoid ( Monoid(..) )
import System.Directory
( getDirectoryContents, doesFileExist, getTemporaryDirectory )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension,
splitExtension, splitDirectories, joinPath )
splitExtension )
import System.IO (hClose, hPutStrLn)
import System.Environment (getEnv)
import Distribution.Compat.Exception (catchExit, catchIO)
......@@ -912,7 +911,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi,
ghcOptRPaths = if (hostOS == OSX
&& relocatable lbi)
then toRPaths False pkg_descr lbi clbi
then toRPaths False pkg_descr lbi
else mempty
}
......@@ -936,41 +935,21 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
toRPaths :: Bool -- ^ Building exe?
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> NubListR FilePath
toRPaths buildE _pkg_descr lbi clbi = toNubListR $ map (libPref </>) depsK
toRPaths buildE _pkg_descr lbi = toNubListR (map (hostPref </>) refDirs)
where
(Platform _hostArch hostOS) = hostPlatform lbi
ipkgs = installedPkgs lbi
deps = map fst (componentPackageDeps clbi)
depsP = catMaybes (map (PackageIndex.lookupInstalledPackageId ipkgs) deps)
depsK = if packageKeySupported (compiler lbi)
then map (display . InstalledPackageInfo.packageKey) depsP
else map (display . snd) (componentPackageDeps clbi)
installDirs = fmap fromJust (prefixRelativeInstallDirs (packageId _pkg_descr) lbi)
relPref = shortRelativePath (bindir installDirs)
(takeDirectory (libdir installDirs))
libPref = case hostOS of
OSX -> if buildE
then "@loader_path" </> relPref
else "@origin" </> ".."
_ -> if buildE
then "$ORIGIN" </> relPref
else "$ORIGIN" </> ".."
dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])
dropCommonPrefix (x:xs) (y:ys)
| x == y = dropCommonPrefix xs ys
dropCommonPrefix xs ys = (xs,ys)
shortRelativePath :: FilePath -> FilePath -> FilePath
shortRelativePath from to =
case dropCommonPrefix (splitDirectories from) (splitDirectories to) of
(stuff, path) -> joinPath (map (const "..") stuff ++ path)
installDirs = absoluteInstallDirs _pkg_descr lbi NoCopyDest
relDir | buildE = bindir installDirs
| otherwise = libdir installDirs
ipkgs = PackageIndex.allPackages (installedPkgs lbi)
allDepLibDirs = concatMap InstalledPackageInfo.libraryDirs ipkgs
refDirs = map (shortRelativePath relDir) allDepLibDirs
(Platform _ hostOS) = hostPlatform lbi
hostPref = case hostOS of
OSX -> "@loader_path"
_ -> "$ORIGIN"
-- | Start a REPL without loading any source files.
startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler
......@@ -1073,7 +1052,7 @@ buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi
[exeDir </> x | x <- cObjs],
ghcOptRPaths = if (hostOS == OSX
&& relocatable lbi)
then toRPaths True _pkg_descr lbi clbi
then toRPaths True _pkg_descr lbi
else mempty
}
replOpts = baseOpts {
......
......@@ -28,7 +28,6 @@ module Distribution.Simple.InstallDirs (
CopyDest(..),
prefixRelativeInstallDirs,
substituteInstallDirTemplates,
substituteInstallDirTemplatesNP,
PathTemplate,
PathTemplateVariable(..),
......@@ -281,42 +280,6 @@ substituteInstallDirTemplates env dirs = dirs'
prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar]
prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar]
-- | Like 'substituteInstallDirTemplates', but does not allow substitution of
-- the 'prefix' variable
substituteInstallDirTemplatesNP :: PathTemplateEnv
-> InstallDirTemplates -> InstallDirTemplates
substituteInstallDirTemplatesNP env dirs = dirs'
where
dirs' = InstallDirs {
-- So this specifies exactly which vars are allowed in each template
prefix = subst prefix [],
bindir = subst bindir [],
libdir = subst libdir [bindirVar],
libsubdir = subst libsubdir [],
dynlibdir = subst dynlibdir [bindirVar, libdirVar],
libexecdir = subst libexecdir prefixBinLibVars,
includedir = subst includedir prefixBinLibVars,
datadir = subst datadir prefixBinLibVars,
datasubdir = subst datasubdir [],
docdir = subst docdir prefixBinLibDataVars,
mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]),
htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]),
haddockdir = subst haddockdir (prefixBinLibDataVars ++
[docdirVar, htmldirVar]),
sysconfdir = subst sysconfdir prefixBinLibVars
}
subst dir env' = substPathTemplate (env'++env) (dir dirs)
bindirVar = (BindirVar, bindir dirs')
libdirVar = (LibdirVar, libdir dirs')
libsubdirVar = (LibsubdirVar, libsubdir dirs')
datadirVar = (DatadirVar, datadir dirs')
datasubdirVar = (DatasubdirVar, datasubdir dirs')
docdirVar = (DocdirVar, docdir dirs')
htmldirVar = (HtmldirVar, htmldir dirs')
prefixBinLibVars = [bindirVar, libdirVar, libsubdirVar]
prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar]
-- | Convert from abstract install directories to actual absolute ones by
-- substituting for all the variables in the abstract paths, to get real
-- absolute path.
......
......@@ -19,6 +19,7 @@ module Distribution.Simple.Program.HcPkg (
hide,
dump,
list,
pkgRoot,
-- * Program invocations
initInvocation,
......@@ -271,6 +272,48 @@ list verbosity hcPkg packagedb = do
where
parsePackageIds = sequence . map simpleParse . words
-- | Call @hc-pkg@ to get the location of PackageDB.
pkgRoot :: Verbosity -> ConfiguredProgram -> PackageDB -> IO (Maybe FilePath)
pkgRoot _ _ (SpecificPackageDB fp) = return (Just fp)
pkgRoot verbosity hcPkg packagedb = do
output <- getProgramInvocationOutput verbosity
(dumpInvocation hcPkg verbosity packagedb)
`catchExit` \_ -> die $ programId hcPkg ++ " pkgRoot failed"
case parsePkgRoot output of
Left ok -> return ok
_ -> die $ "failed to parse output of '"
++ programId hcPkg ++ " pkgRoot'"
where
parsePkgRoot str = case splitPkgs str of
[] -> Left Nothing
(pkg:_) -> case parsePkgRoot' pkg of
ParseOk _ pkgroot -> Left pkgroot
ParseFailed msg -> Right msg
parsePkgRoot' = parseFieldsFlat [pkgrootField] Nothing
where
pkgrootField =
simpleField "pkgroot"
showFilePath parseFilePathQ
(fromMaybe "") (\x _ -> Just x)
--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
--------------------------
-- The program invocations
......
......@@ -40,7 +40,7 @@ import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
, ComponentName(..), getComponentLocalBuildInfo
, LibraryName(..)
, InstallDirs(..), absoluteInstallDirs, prefixRelativeInstallDirs )
, InstallDirs(..), absoluteInstallDirs )
import Distribution.Simple.BuildPaths (haddockName)
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.LHC as LHC
......@@ -48,7 +48,8 @@ import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import Distribution.Simple.Compiler
( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor
, PackageDBStack, registrationPackageDB )
, PackageDB, PackageDBStack, absolutePackageDBPaths
, registrationPackageDB )
import Distribution.Simple.Program
( ProgramConfiguration, ConfiguredProgram
, runProgramInvocation, requireProgram, lookupProgram
......@@ -69,7 +70,7 @@ import Distribution.InstalledPackageInfo
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Simple.Utils
( writeUTF8File, writeFileAtomic, setFileExecutable
, die, notice, setupMessage )
, die, notice, setupMessage, shortRelativePath )
import Distribution.System
( OS(..), buildOS )
import Distribution.Text
......@@ -84,7 +85,7 @@ import System.Directory
import Control.Monad (when)
import Data.Maybe
( isJust, fromJust, fromMaybe, maybeToList )
( isJust, fromMaybe, maybeToList )
import Data.List
( partition, nub )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
......@@ -99,8 +100,10 @@ register pkg@PackageDescription { library = Just lib } lbi regFlags
= do
let clbi = getComponentLocalBuildInfo lbi CLibName
absPackageDBs <- absolutePackageDBPaths packageDbs
installedPkgInfo <- generateRegistrationInfo
verbosity pkg lib lbi clbi inplace reloc distPref
(registrationPackageDB absPackageDBs)
when (fromFlag (regPrintId regFlags)) $ do
putStrLn (display (IPI.installedPackageId installedPkgInfo))
......@@ -156,8 +159,9 @@ generateRegistrationInfo :: Verbosity
-> Bool
-> Bool
-> FilePath
-> PackageDB
-> IO InstalledPackageInfo
generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref = do
generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do
--TODO: eliminate pwd!
pwd <- getCurrentDirectory
......@@ -172,16 +176,45 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref = do
_other -> do
return (InstalledPackageId (display (packageId pkg)))
let installedPkgInfo
| inplace = inplaceInstalledPackageInfo pwd distPref
pkg ipid lib lbi clbi
| reloc = relocatableInstalledPackageInfo
pkg ipid lib lbi clbi
| otherwise = absoluteInstalledPackageInfo
pkg ipid lib lbi clbi
-- let installedPkgInfo
-- | inplace = inplaceInstalledPackageInfo pwd distPref
-- pkg ipid lib lbi clbi
-- | reloc = relocatableInstalledPackageInfo
-- pkg ipid lib lbi clbi undefined
-- | otherwise = absoluteInstalledPackageInfo
-- pkg ipid lib lbi clbi
installedPkgInfo <- if inplace then
return (inplaceInstalledPackageInfo pwd distPref
pkg ipid lib lbi clbi)
else if reloc then
relocRegistrationInfo verbosity pkg lib lbi clbi ipid
packageDb
else
return (absoluteInstalledPackageInfo
pkg ipid lib lbi clbi)
return installedPkgInfo{ IPI.installedPackageId = ipid }
relocRegistrationInfo :: Verbosity
-> PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageId
-> PackageDB
-> IO InstalledPackageInfo
relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb =
case (compilerFlavor (compiler lbi)) of
GHC -> do let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
fsM <- HcPkg.pkgRoot verbosity ghcPkg packageDb
case fsM of
Just fs -> return (relocatableInstalledPackageInfo
pkg ipid lib lbi clbi fs)
Nothing -> die "Cannot register relocatable package with empty ${pkgroot}"
_ -> die "Distribution.Simple.Register.relocRegistrationInfo: \
\not implemented for this compiler"
-- | Create an empty package DB at the specified location.
initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath
......@@ -383,8 +416,9 @@ relocatableInstalledPackageInfo :: PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> InstalledPackageInfo
relocatableInstalledPackageInfo pkg ipid lib lbi clbi =
relocatableInstalledPackageInfo pkg ipid lib lbi clbi pkgroot =
generalInstalledPackageInfo adjustReativeIncludeDirs
pkg ipid lib lbi clbi installDirs
where
......@@ -394,8 +428,9 @@ relocatableInstalledPackageInfo pkg ipid lib lbi clbi =
| null (installIncludes bi) = []
| otherwise = [includedir installDirs]
bi = libBuildInfo lib
installDirs = fmap (((("${pkgroot}" </> "..") </> "..") </>) . fromJust)
$ prefixRelativeInstallDirs (packageId pkg) lbi
installDirs = fmap (("${pkgroot}" </>) . shortRelativePath pkgroot)
$ absoluteInstallDirs pkg lbi NoCopyDest
-- -----------------------------------------------------------------------------
-- Unregistration
......
......@@ -62,6 +62,7 @@ module Distribution.Simple.Utils (
-- * file names
currentDir,
shortRelativePath,
-- * finding files
findFile,
......@@ -150,7 +151,7 @@ import System.Exit
( exitWith, ExitCode(..) )
import System.FilePath
( normalise, (</>), (<.>)
, getSearchPath, takeDirectory, splitFileName
, getSearchPath, joinPath, takeDirectory, splitFileName
, splitExtension, splitExtensions, splitDirectories )
import System.Directory
( createDirectory, renameFile, removeDirectoryRecursive )
......@@ -1063,6 +1064,16 @@ rewriteFile path newContent =
currentDir :: FilePath
currentDir = "."
shortRelativePath :: FilePath -> FilePath -> FilePath
shortRelativePath from to =
case dropCommonPrefix (splitDirectories from) (splitDirectories to) of
(stuff, path) -> joinPath (map (const "..") stuff ++ path)
where
dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])
dropCommonPrefix (x:xs) (y:ys)
| x == y = dropCommonPrefix xs ys
dropCommonPrefix xs ys = (xs,ys)
-- ------------------------------------------------------------
-- * Finding the description file
-- ------------------------------------------------------------
......
......@@ -1421,7 +1421,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key
defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False
return $ configFlags' {
configInstallDirs = fmap Cabal.Flag .
InstallDirs.substituteInstallDirTemplatesNP env $
InstallDirs.substituteInstallDirTemplates env $
InstallDirs.combineInstallDirs fromFlagOrDefault
defInstallDirs (configInstallDirs configFlags)
}
......
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