Factor out 'getLibDir' / 'getBaseDir' into a new GHC.BaseDir ghc-boot module

ghc-pkg and ghc already both needed this. I figure it is better to
deduplicate, especially seeing that changes to one (FreeBSD CPP) didn't
make it to the other.

Additionally in !1090 I make ghc-pkg look up the settings file, which
makes it use the top dir a bit more widely. If that lands, any
difference in the way they find the top dir would be more noticable.

That change also means sharing more code between ghc and ghc-package
(namely the settings file parsing code), so I'd think it better to get
off the slipperly slope of duplicating code now.

1 files changed, 61 insertions, 0 deletions

diff --git a/libraries/ghc-boot/GHC/BaseDir.hs b/libraries/ghc-boot/GHC/BaseDir.hs
new file mode 100644
index 0000000000..cc83355144
--- /dev/null
+++ b/libraries/ghc-boot/GHC/BaseDir.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE CPP #-}
+
+-- | Note [Base Dir]
+-- ~~~~~~~~~~~~~~~~~
+--
+-- GHC's base directory or top directory containers miscellaneous settings and
+-- the package database.  The main compiler of course needs this directory to
+-- read those settings and read and write packages. ghc-pkg uses it to find the
+-- global package database too.
+--
+-- In the interest of making GHC builds more relocatable, many settings also
+-- will expand `${top_dir}` inside strings so GHC doesn't need to know it's on
+-- installation location at build time. ghc-pkg also can expand those variables
+-- and so needs the top dir location to do that too.
+module GHC.BaseDir where
+
+import Prelude -- See note [Why do we import Prelude here?]
+
+import System.FilePath
+
+-- Windows
+#if defined(mingw32_HOST_OS)
+import System.Environment (getExecutablePath)
+-- POSIX
+#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
+import System.Environment (getExecutablePath)
+#endif
+
+-- | Calculate the location of the base dir
+getBaseDir :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
+getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath
+  where
+    -- locate the "base dir" when given the path
+    -- to the real ghc executable (as opposed to symlink)
+    -- that is running this function.
+    rootDir :: FilePath -> FilePath
+    rootDir = takeDirectory . takeDirectory . normalise
+#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
+-- on unix, this is a bit more confusing.
+-- The layout right now is something like
+--
+--   /bin/ghc-X.Y.Z <- wrapper script (1)
+--   /bin/ghc       <- symlink to wrapper script (2)
+--   /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3)
+--   /lib/ghc-X.Y.Z <- $topdir (4)
+--
+-- As such, we first need to find the absolute location to the
+-- binary.
+--
+-- getExecutablePath will return (3). One takeDirectory will
+-- give use /lib/ghc-X.Y.Z/bin, and another will give us (4).
+--
+-- This of course only works due to the current layout. If
+-- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib}
+-- this would need to be changed accordingly.
+--
+getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
+#else
+getBaseDir = return Nothing
+#endif