Commit 387050d0 authored by John Ericson's avatar John Ericson Committed by Marge Bot

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.
parent d1dc0ed7
Pipeline #6558 passed with stages
in 383 minutes and 44 seconds
......@@ -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.
......
{-# 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
......@@ -37,6 +37,7 @@ Library
default-extensions: NoImplicitPrelude
exposed-modules:
GHC.BaseDir
GHC.LanguageExtensions
GHC.PackageDb
GHC.Serialized
......
......@@ -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
......@@ -2177,17 +2176,6 @@ reportError s = do hFlush stdout; hPutStrLn stderr s
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
......
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