ghc-pkg needs settings file to un-hardcode target platform

This matches GHC itself getting the target platform from there.

3 files changed, 123 insertions, 1 deletions

diff --git a/libraries/ghc-boot/GHC/BaseDir.hs b/libraries/ghc-boot/GHC/BaseDir.hs
index cc83355144..196ab2eb72 100644
--- a/libraries/ghc-boot/GHC/BaseDir.hs
+++ b/libraries/ghc-boot/GHC/BaseDir.hs
@@ -14,8 +14,9 @@
 -- 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 Prelude -- See Note [Why do we import Prelude here?]
 
+import Data.List
 import System.FilePath
 
 -- Windows
@@ -26,6 +27,21 @@ import System.Environment (getExecutablePath)
 import System.Environment (getExecutablePath)
 #endif
 
+-- | Expand occurrences of the @$topdir@ interpolation in a string.
+expandTopDir :: FilePath -> String -> String
+expandTopDir = expandPathVar "topdir"
+
+-- | @expandPathVar var value str@
+--
+--   replaces occurences of variable @$var@ with @value@ in str.
+expandPathVar :: String -> FilePath -> String -> String
+expandPathVar var value str
+  | Just str' <- stripPrefix ('$':var) str
+  , null str' || isPathSeparator (head str')
+  = value ++ expandPathVar var value str'
+expandPathVar var value (x:xs) = x : expandPathVar var value xs
+expandPathVar _ _ [] = []
+
 -- | Calculate the location of the base dir
 getBaseDir :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
diff --git a/libraries/ghc-boot/GHC/Settings.hs b/libraries/ghc-boot/GHC/Settings.hs
new file mode 100644
index 0000000000..fc9f95a586
--- /dev/null
+++ b/libraries/ghc-boot/GHC/Settings.hs
@@ -0,0 +1,104 @@
+-- Note [Settings file]
+-- ~~~~~~~~~~~~~~~~~~~~
+--
+-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time
+-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU
+-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is
+-- associated with the current version/target.
+--
+-- This module has just enough code to read key value pairs from the settings
+-- file, and read the target platform from those pairs.
+--
+-- The  "0" suffix is because the caller will partially apply it, and that will
+-- in turn be used a few more times.
+module GHC.Settings where
+
+import Prelude -- See Note [Why do we import Prelude here?]
+
+import GHC.BaseDir
+import GHC.Platform
+
+import Data.Char (isSpace)
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-----------------------------------------------------------------------------
+-- parts of settings file
+
+getTargetPlatform
+  :: FilePath -> RawSettings -> Either String Platform
+getTargetPlatform settingsFile mySettings = do
+  let
+    getBooleanSetting = getBooleanSetting0 settingsFile mySettings
+    readSetting :: (Show a, Read a) => String -> Either String a
+    readSetting = readSetting0 settingsFile mySettings
+
+  targetArch <- readSetting "target arch"
+  targetOS <- readSetting "target os"
+  targetWordSize <- readSetting "target word size"
+  targetUnregisterised <- getBooleanSetting "Unregisterised"
+  targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
+  targetHasIdentDirective <- readSetting "target has .ident directive"
+  targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
+  crossCompiling <- getBooleanSetting "cross compiling"
+
+  pure $ Platform
+    { platformArch = targetArch
+    , platformOS   = targetOS
+    , platformWordSize = targetWordSize
+    , platformUnregisterised = targetUnregisterised
+    , platformHasGnuNonexecStack = targetHasGnuNonexecStack
+    , platformHasIdentDirective = targetHasIdentDirective
+    , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
+    , platformIsCrossCompiling = crossCompiling
+    }
+
+-----------------------------------------------------------------------------
+-- settings file helpers
+
+type RawSettings = Map String String
+
+-- | See Note [Settings file] for "0" suffix
+getSetting0
+  :: FilePath -> RawSettings -> String -> Either String String
+getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of
+  Just xs -> Right xs
+  Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
+
+-- | See Note [Settings file] for "0" suffix
+getFilePathSetting0
+  :: FilePath -> FilePath -> RawSettings -> String -> Either String String
+getFilePathSetting0 top_dir settingsFile mySettings key =
+  expandTopDir top_dir <$> getSetting0 settingsFile mySettings key
+
+-- | See Note [Settings file] for "0" suffix
+getBooleanSetting0
+  :: FilePath -> RawSettings -> String -> Either String Bool
+getBooleanSetting0 settingsFile mySettings key = do
+  rawValue <- getSetting0 settingsFile mySettings key
+  case rawValue of
+    "YES" -> Right True
+    "NO" -> Right False
+    xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs
+
+-- | See Note [Settings file] for "0" suffix
+readSetting0
+  :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a
+readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of
+  Just xs -> case maybeRead xs of
+    Just v -> Right v
+    Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs
+  Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
+
+-----------------------------------------------------------------------------
+-- read helpers
+
+maybeRead :: Read a => String -> Maybe a
+maybeRead str = case reads str of
+  [(x, "")] -> Just x
+  _ -> Nothing
+
+maybeReadFuzzy :: Read a => String -> Maybe a
+maybeReadFuzzy str = case reads str of
+  [(x, s)] | all isSpace s -> Just x
+  _ -> Nothing
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index 15721b1489..650f7518dc 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -44,10 +44,12 @@ Library
             GHC.ForeignSrcLang
             GHC.HandleEncoding
             GHC.Platform
+            GHC.Settings
 
     build-depends: base       >= 4.7 && < 4.14,
                    binary     == 0.8.*,
                    bytestring == 0.10.*,
+                   containers >= 0.5 && < 0.7,
                    directory  >= 1.2 && < 1.4,
                    filepath   >= 1.3 && < 1.5,
                    ghc-boot-th == @ProjectVersionMunged@