Relocatable packages

Cabal/Distribution/InstalledPackageInfo.hs

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

Cabal/Distribution/Simple/Build/PathsModule.hs

@@ -32,6 +32,8 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Setup ( CopyDest(NoCopyDest) )
 import Distribution.Simple.BuildPaths
          ( autogenModuleName )
+import Distribution.Simple.Utils
+         ( shortRelativePath )
 import Distribution.Text
          ( display )
 import Distribution.Version
@@ -62,6 +64,11 @@ generate pkg_descr lbi =
           "import Foreign\n"++
           "import Foreign.C\n"
 
+       reloc_imports
+        | reloc =
+          "import System.Environment (getExecutablePath)\n"
+        | otherwise = ""
+
        header =
         pragmas++
         "module " ++ display paths_modulename ++ " (\n"++
@@ -74,16 +81,36 @@ generate pkg_descr lbi =
         "import qualified Control.Exception as Exception\n"++
         "import Data.Version (Version(..))\n"++
         "import System.Environment (getEnv)\n"++
+        reloc_imports ++
         "import Prelude\n"++
         "\n"++
         "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
         "catchIO = Exception.catch\n" ++
         "\n"++
-        "\nversion :: Version"++
+        "version :: Version"++
         "\nversion = Version " ++ show branch ++ " " ++ show tags
           where Version branch tags = packageVersion pkg_descr
 
        body
+        | reloc =
+          "\n\nbindirrel :: FilePath\n" ++
+          "bindirrel = " ++ show flat_bindirreloc ++
+          "\n"++
+          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++
+          "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++
+          "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++
+          "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++
+          "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++
+          "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++
+          "\n"++
+          "getDataFileName :: FilePath -> IO FilePath\n"++
+          "getDataFileName name = do\n"++
+          "  dir <- getDataDir\n"++
+          "  return (dir `joinFileName` name)\n"++
+          "\n"++
+          get_prefix_reloc_stuff++
+          "\n"++
+          filename_stuff
         | absolute =
           "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++
           "\nbindir     = " ++ show flat_bindir ++
@@ -146,9 +173,20 @@ generate pkg_descr lbi =
           sysconfdir = flat_sysconfdirrel
         } = prefixRelativeInstallDirs (packageId pkg_descr) lbi
 
+        flat_bindirreloc = shortRelativePath flat_prefix flat_bindir
+        flat_libdirreloc = shortRelativePath flat_prefix flat_libdir
+        flat_datadirreloc = shortRelativePath flat_prefix flat_datadir
+        flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir
+        flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir
+
         mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel
         mkGetDir dir Nothing       = "return " ++ show dir
 
+        mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++
+                                     " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++
+                                     "\")"
+          where var' = pkgPathEnvVar pkg_descr var
+
         mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++
                               " (\\_ -> "++expr++")"
           where var' = pkgPathEnvVar pkg_descr var
@@ -159,6 +197,8 @@ generate pkg_descr lbi =
           || isNothing flat_bindirrel -- if the bin dir is an absolute path
           || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))
 
+        reloc = relocatable lbi
+
         supportsRelocatableProgs GHC  = case buildOS of
                            Windows   -> True
                            _         -> False
@@ -188,6 +228,14 @@ pkgPathEnvVar pkg_descr var =
         fixchar '-' = '_'
         fixchar c   = c
 
+get_prefix_reloc_stuff :: String
+get_prefix_reloc_stuff =
+  "getPrefixDirReloc :: FilePath -> IO FilePath\n"++
+  "getPrefixDirReloc dirRel = do\n"++
+  "  exePath <- getExecutablePath\n"++
+  "  let (bindir,_) = splitFileName exePath\n"++
+  "  return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"
+
 get_prefix_win32 :: Arch -> String
 get_prefix_win32 arch =
   "getPrefixDirRel :: FilePath -> IO FilePath\n"++

Cabal/Distribution/Simple/Configure.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -104,7 +105,7 @@ import Distribution.Simple.Utils
     , writeFileAtomic
     , withTempFile )
 import Distribution.System
-    ( OS(..), buildOS, Platform, buildPlatform )
+    ( OS(..), buildOS, Platform (..), buildPlatform )
 import Distribution.Version
          ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion )
 import Distribution.Verbosity
@@ -126,9 +127,9 @@ import Data.Binary ( decodeOrFail, encode )
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.List
-    ( (\\), nub, partition, isPrefixOf, inits )
+    ( (\\), nub, partition, isPrefixOf, inits, stripPrefix )
 import Data.Maybe
-    ( isNothing, catMaybes, fromMaybe )
+    ( isNothing, catMaybes, fromMaybe, isJust )
 import Data.Either
     ( partitionEithers )
 import qualified Data.Set as Set
@@ -601,6 +602,11 @@ configure (pkg_descr0, pbi) cfg
                   GHC.ghcDynamic comp
                 _ -> False
 
+        reloc <-
+           if not (fromFlag $ configRelocatable cfg)
+                then return False
+                else return True
+
         let lbi = LocalBuildInfo {
                     configFlags         = cfg,
                     extraConfigArgs     = [],  -- Currently configure does not
@@ -631,9 +637,12 @@ configure (pkg_descr0, pbi) cfg
                     stripLibs           = fromFlag $ configStripLibs cfg,
                     withPackageDB       = packageDbs,
                     progPrefix          = fromFlag $ configProgPrefix cfg,
-                    progSuffix          = fromFlag $ configProgSuffix cfg
+                    progSuffix          = fromFlag $ configProgSuffix cfg,
+                    relocatable         = reloc
                   }
 
+        when reloc (checkRelocatable verbosity pkg_descr lbi)
+
         let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
             relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi
 
@@ -1554,3 +1563,69 @@ checkPackageProblems verbosity gpkg pkg = do
   if null errors
     then mapM_ (warn verbosity) warnings
     else die (intercalate "\n\n" errors)
+
+-- | Preform checks if a relocatable build is allowed
+checkRelocatable :: Verbosity
+                 -> PackageDescription
+                 -> LocalBuildInfo
+                 -> IO ()
+checkRelocatable verbosity pkg lbi
+    = sequence_ [ checkOS
+                , checkCompiler
+                , packagePrefixRelative
+                , depsPrefixRelative
+                ]
+  where
+    -- Check if the OS support relocatable builds.
+    --
+    -- If you add new OS' to this list, and your OS supports dynamic libraries
+    -- and RPATH, make sure you add your OS to RPATH-support list of:
+    -- Distribution.Simple.GHC.getRPaths
+    checkOS
+        = unless (os `elem` [ OSX, Linux ])
+        $ die $ "Operating system: " ++ display os ++
+                ", does not support relocatable builds"
+      where
+        (Platform _ os) = hostPlatform lbi
+
+    -- Check if the Compiler support relocatable builds
+    checkCompiler
+        = unless (compilerFlavor comp `elem` [ GHC ])
+        $ die $ "Compiler: " ++ show comp ++
+                ", does not support relocatable builds"
+      where
+        comp = compiler lbi
+
+    -- Check if all the install dirs are relative to same prefix
+    packagePrefixRelative
+        = unless (relativeInstallDirs installDirs)
+        $ die $ "Installation directories are not prefix_relative:\n" ++
+                show installDirs
+      where
+        installDirs = absoluteInstallDirs pkg lbi NoCopyDest
+        p           = prefix installDirs
+        relativeInstallDirs (InstallDirs {..}) =
+          all isJust
+              (fmap (stripPrefix p)
+                    [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir
+                    , docdir, mandir, htmldir, haddockdir, sysconfdir] )
+
+    -- 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 = do
+        pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))
+        mapM_ (doCheck pkgr) ipkgs
+      where
+        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