Correctly calculate relative paths for relocatable packages

Cabal/Distribution/Simple/GHC.hs

@@ -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 {

Cabal/Distribution/Simple/InstallDirs.hs

@@ -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.

Cabal/Distribution/Simple/Program/HcPkg.hs

@@ -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

Cabal/Distribution/Simple/Register.hs

@@ -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

Cabal/Distribution/Simple/Utils.hs

@@ -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
 -- ------------------------------------------------------------

cabal-install/Distribution/Client/Install.hs

@@ -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)
           }