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.

4 files changed, 68 insertions, 55 deletions

diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs
index d01d5214b4..1293d1898a 100644
--- a/compiler/main/SysTools/BaseDir.hs
+++ b/compiler/main/SysTools/BaseDir.hs
@@ -20,20 +20,17 @@ module SysTools.BaseDir
 
 import GhcPrelude
 
+-- See note [Base Dir] for why some of this logic is shared with ghc-pkg.
+import GHC.BaseDir
+
 import Panic
 
 import System.Environment (lookupEnv)
 import System.FilePath
 import Data.List
 
--- POSIX
-#if defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
-import System.Environment (getExecutablePath)
-#endif
-
 -- Windows
 #if defined(mingw32_HOST_OS)
-import System.Environment (getExecutablePath)
 import System.Directory (doesDirectoryExist)
 #endif
 
@@ -125,40 +122,6 @@ findTopDir Nothing
                          InstallationError "missing -B<dir> option"
                      Just dir -> return dir
 
-getBaseDir :: IO (Maybe String)
-
-#if defined(mingw32_HOST_OS)
-
--- 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
-
-getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath
-#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
 
 -- See Note [tooldir: How GHC finds mingw and perl on Windows]
 -- Returns @Nothing@ when not on Windows.
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
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index 3292118fa4..97872c15f7 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -37,6 +37,7 @@ Library
     default-extensions: NoImplicitPrelude
 
     exposed-modules:
+            GHC.BaseDir
             GHC.LanguageExtensions
             GHC.PackageDb
             GHC.Serialized
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 4886d85f74..02ac7d22d9 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -31,6 +31,7 @@ import Version ( version, targetOS, targetARCH )
 import qualified GHC.PackageDb as GhcPkg
 import GHC.PackageDb (BinaryStringRep(..))
 import GHC.HandleEncoding
+import GHC.BaseDir (getBaseDir)
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import qualified Data.Graph as Graph
 import qualified Distribution.ModuleName as ModuleName
@@ -66,9 +67,6 @@ import System.Directory ( doesDirectoryExist, getDirectoryContents,
                           getCurrentDirectory )
 import System.Exit ( exitWith, ExitCode(..) )
 import System.Environment ( getArgs, getProgName, getEnv )
-#if defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(mingw32_HOST_OS)
-import System.Environment ( getExecutablePath )
-#endif
 import System.IO
 import System.IO.Error
 import GHC.IO.Exception (IOErrorType(InappropriateType))
@@ -601,7 +599,8 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
   let err_msg = "missing --global-package-db option, location of global package database unknown\n"
   global_conf <-
      case [ f | FlagGlobalConfig f <- my_flags ] of
-        [] -> do mb_dir <- getLibDir
+        -- See note [Base Dir] for more information on the base dir / top dir.
+        [] -> do mb_dir <- getBaseDir
                  case mb_dir of
                    Nothing  -> die err_msg
                    Just dir -> do
@@ -2178,17 +2177,6 @@ dieForcible :: String -> IO ()
 dieForcible s = die (s ++ " (use --force to override)")
 
 -----------------------------------------
--- Cut and pasted from ghc/compiler/main/SysTools
-
-getLibDir :: IO (Maybe String)
-
-#if defined(mingw32_HOST_OS) || defined(darwin_HOST_OS) || defined(linux_HOST_OS)
-getLibDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
-#else
-getLibDir = return Nothing
-#endif
-
------------------------------------------
 -- Adapted from ghc/compiler/utils/Panic
 
 installSignalHandlers :: IO ()