{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module GHC.Settings.IO
 ( SettingsError (..)
 , initSettings
 ) where

import GHC.Prelude

import GHC.Settings.Utils

import GHC.Settings.Config
import GHC.Utils.CliOption
import GHC.Utils.Fingerprint
import GHC.Platform
import GHC.Utils.Panic
import GHC.Settings
import GHC.SysTools.BaseDir
import GHC.Unit.Types

import Control.Monad.Trans.Except
import Control.Monad.IO.Class
import qualified Data.Map as Map
import System.FilePath
import System.Directory

import GHC.Toolchain.Program
import GHC.Toolchain
import GHC.Data.Maybe
import Data.Bifunctor (Bifunctor(second))

data SettingsError
  = SettingsError_MissingData String
  | SettingsError_BadData String

initSettings
  :: forall m
  .  MonadIO m
  => String -- ^ TopDir path
  -> ExceptT SettingsError m Settings
initSettings :: forall (m :: * -> *).
MonadIO m =>
String -> ExceptT SettingsError m Settings
initSettings String
top_dir = do
  let installed :: FilePath -> FilePath
      installed :: String -> String
installed String
file = String
top_dir String -> String -> String
</> String
file
      libexec :: FilePath -> FilePath
      libexec :: String -> String
libexec String
file = String
top_dir String -> String -> String
</> String
".." String -> String -> String
</> String
"bin" String -> String -> String
</> String
file
      settingsFile :: String
settingsFile = String -> String
installed String
"settings"
      targetFile :: String
targetFile   = String -> String
installed (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"targets" String -> String -> String
</> String
"default.target"

      readFileSafe :: FilePath -> ExceptT SettingsError m String
      readFileSafe :: String -> ExceptT SettingsError m String
readFileSafe String
path = IO Bool -> ExceptT SettingsError m Bool
forall a. IO a -> ExceptT SettingsError m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesFileExist String
path) ExceptT SettingsError m Bool
-> (Bool -> ExceptT SettingsError m String)
-> ExceptT SettingsError m String
forall a b.
ExceptT SettingsError m a
-> (a -> ExceptT SettingsError m b) -> ExceptT SettingsError m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> IO String -> ExceptT SettingsError m String
forall a. IO a -> ExceptT SettingsError m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT SettingsError m String)
-> IO String -> ExceptT SettingsError m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
path
        Bool
False -> SettingsError -> ExceptT SettingsError m String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SettingsError -> ExceptT SettingsError m String)
-> SettingsError -> ExceptT SettingsError m String
forall a b. (a -> b) -> a -> b
$ String -> SettingsError
SettingsError_MissingData (String -> SettingsError) -> String -> SettingsError
forall a b. (a -> b) -> a -> b
$ String
"Missing file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path

  settingsStr <- String -> ExceptT SettingsError m String
readFileSafe String
settingsFile
  settingsList <- case maybeReadFuzzy settingsStr of
    Just [(String, String)]
s -> [(String, String)] -> ExceptT SettingsError m [(String, String)]
forall a. a -> ExceptT SettingsError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(String, String)]
s
    Maybe [(String, String)]
Nothing -> SettingsError -> ExceptT SettingsError m [(String, String)]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SettingsError -> ExceptT SettingsError m [(String, String)])
-> SettingsError -> ExceptT SettingsError m [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> SettingsError
SettingsError_BadData (String -> SettingsError) -> String -> SettingsError
forall a b. (a -> b) -> a -> b
$
      String
"Can't parse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
settingsFile
  targetStr <- readFileSafe targetFile
  target <- case maybeReadFuzzy @Target targetStr of
    Just Target
s -> Target -> ExceptT SettingsError m Target
forall a. a -> ExceptT SettingsError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Target
s
    Maybe Target
Nothing -> SettingsError -> ExceptT SettingsError m Target
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SettingsError -> ExceptT SettingsError m Target)
-> SettingsError -> ExceptT SettingsError m Target
forall a b. (a -> b) -> a -> b
$ String -> SettingsError
SettingsError_BadData (String -> SettingsError) -> String -> SettingsError
forall a b. (a -> b) -> a -> b
$
      String
"Can't parse as Target " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
targetFile
  let mySettings = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
settingsList
      getBooleanSetting :: String -> ExceptT SettingsError m Bool
      getBooleanSetting String
key = (String -> ExceptT SettingsError m Bool)
-> (Bool -> ExceptT SettingsError m Bool)
-> Either String Bool
-> ExceptT SettingsError m Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ExceptT SettingsError m Bool
forall a. HasCallStack => String -> a
pgmError Bool -> ExceptT SettingsError m Bool
forall a. a -> ExceptT SettingsError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Bool -> ExceptT SettingsError m Bool)
-> Either String Bool -> ExceptT SettingsError m Bool
forall a b. (a -> b) -> a -> b
$
        String -> Map String String -> String -> Either String Bool
getRawBooleanSetting String
settingsFile Map String String
mySettings String
key

  -- see Note [topdir: How GHC finds its files]
  -- NB: top_dir is assumed to be in standard Unix
  -- format, '/' separated
  mtool_dir <- liftIO $ findToolDir top_dir
        -- see Note [tooldir: How GHC finds mingw on Windows]

  let getSetting_raw String
key = (String -> ExceptT SettingsError m String)
-> (String -> ExceptT SettingsError m String)
-> Either String String
-> ExceptT SettingsError m String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ExceptT SettingsError m String
forall a. HasCallStack => String -> a
pgmError String -> ExceptT SettingsError m String
forall a. a -> ExceptT SettingsError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> ExceptT SettingsError m String)
-> Either String String -> ExceptT SettingsError m String
forall a b. (a -> b) -> a -> b
$
        String -> Map String String -> String -> Either String String
getRawSetting String
settingsFile Map String String
mySettings String
key
      getSetting_topDir String
top String
key = (String -> ExceptT SettingsError m String)
-> (String -> ExceptT SettingsError m String)
-> Either String String
-> ExceptT SettingsError m String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ExceptT SettingsError m String
forall a. HasCallStack => String -> a
pgmError String -> ExceptT SettingsError m String
forall a. a -> ExceptT SettingsError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> ExceptT SettingsError m String)
-> Either String String -> ExceptT SettingsError m String
forall a b. (a -> b) -> a -> b
$
        String
-> String -> Map String String -> String -> Either String String
getRawFilePathSetting String
top String
settingsFile Map String String
mySettings String
key
      getSetting_toolDir String
top Maybe String
tool String
key =
        Maybe String -> String -> String
expandToolDir Maybe String
tool (String -> String)
-> ExceptT SettingsError m String -> ExceptT SettingsError m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> ExceptT SettingsError m String
getSetting_topDir String
top String
key
      getSetting String
key = String -> String -> ExceptT SettingsError m String
getSetting_topDir String
top_dir String
key
      getToolSetting String
key = String -> Maybe String -> String -> ExceptT SettingsError m String
getSetting_toolDir String
top_dir Maybe String
mtool_dir String
key

      expandDirVars String
top Maybe String
tool = Maybe String -> String -> String
expandToolDir Maybe String
tool (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
expandTopDir String
top

      getToolPath :: (Target -> Program) -> String
      getToolPath Target -> Program
key = String -> Maybe String -> String -> String
expandDirVars String
top_dir Maybe String
mtool_dir (Program -> String
prgPath (Program -> String) -> (Target -> Program) -> Target -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> Program
key (Target -> String) -> Target -> String
forall a b. (a -> b) -> a -> b
$ Target
target)

      getMaybeToolPath :: (Target -> Maybe Program) -> String
      getMaybeToolPath Target -> Maybe Program
key = (Target -> Program) -> String
getToolPath (Program -> Maybe Program -> Program
forall a. a -> Maybe a -> a
fromMaybe (String -> [String] -> Program
Program String
"" []) (Maybe Program -> Program)
-> (Target -> Maybe Program) -> Target -> Program
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> Maybe Program
key)

      getToolFlags :: (Target -> Program) -> [String]
      getToolFlags Target -> Program
key = String -> Maybe String -> String -> String
expandDirVars String
top_dir Maybe String
mtool_dir (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Program -> [String]
prgFlags (Program -> [String]) -> (Target -> Program) -> Target -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> Program
key (Target -> [String]) -> Target -> [String]
forall a b. (a -> b) -> a -> b
$ Target
target)

      getTool :: (Target -> Program) -> (String, [String])
      getTool Target -> Program
key = ((Target -> Program) -> String
getToolPath Target -> Program
key, (Target -> Program) -> [String]
getToolFlags Target -> Program
key)

  let
    (cc_prog, cc_args0)  = getTool (ccProgram . tgtCCompiler)
    (cxx_prog, cxx_args) = getTool (cxxProgram . tgtCxxCompiler)
    (cpp_prog, cpp_args) = getTool (cppProgram . tgtCPreprocessor)
    (hs_cpp_prog, hs_cpp_args) = getTool (hsCppProgram . tgtHsCPreprocessor)
    (js_cpp_prog, js_cpp_args) = getTool (maybe (Program "" []) jsCppProgram . tgtJsCPreprocessor)
    (cmmCpp_prog, cmmCpp_args) = getTool (cmmCppProgram . tgtCmmCPreprocessor)

    platform = Target -> Platform
getTargetPlatform Target
target

    unreg_cc_args = if Platform -> Bool
platformUnregisterised Platform
platform
                    then [String
"-DNO_REGS", String
"-DUSE_MINIINTERPRETER"]
                    else []
    cc_args = [String]
cc_args0 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
unreg_cc_args

    -- The extra flags we need to pass gcc when we invoke it to compile .hc code.
    --
    -- -fwrapv is needed for gcc to emit well-behaved code in the presence of
    -- integer wrap around (#952).
    extraGccViaCFlags = if Platform -> Bool
platformUnregisterised Platform
platform
                          -- configure guarantees cc support these flags
                          then [String
"-fwrapv", String
"-fno-builtin"]
                          else []

  -- The package database is either a relative path to the location of the settings file
  -- OR an absolute path.
  -- In case the path is absolute then top_dir </> abs_path == abs_path
  --         the path is relative then top_dir </> rel_path == top_dir </> rel_path
  globalpkgdb_path <- installed <$> getSetting "Relative Global Package DB"

  let ghc_usage_msg_path  = String -> String
installed String
"ghc-usage.txt"
      ghci_usage_msg_path = String -> String
installed String
"ghci-usage.txt"

  -- For all systems, unlit, split, mangle are GHC utilities
  -- architecture-specific stuff is done when building Config.hs
  unlit_path <- getToolSetting "unlit command"

  -- Other things being equal, 'as' is simply 'gcc'
  let (cc_link, cc_link_args) = getTool (ccLinkProgram . tgtCCompilerLink)
      as_prog      = String
cc_prog
      as_args      = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
cc_args
      ld_prog      = String
cc_link
      ld_args      = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option ([String]
cc_args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
cc_link_args)
      ld_r         = do
        ld_r_prog <- Target -> Maybe MergeObjs
tgtMergeObjs Target
target
        let (ld_r_path, ld_r_args) = getTool (mergeObjsProgram . const ld_r_prog)
        pure (ld_r_path, map Option ld_r_args)
      iserv_prog   = String -> String
libexec String
"ghc-iserv"

  ghcWithInterpreter <- getBooleanSetting "Use interpreter"

  baseUnitId <- getSetting_raw "base unit-id"

  return $ Settings
    { sGhcNameVersion = GhcNameVersion
      { ghcNameVersion_programName = "ghc"
      , ghcNameVersion_projectVersion = cProjectVersion
      }

    , sFileSettings = FileSettings
      { fileSettings_ghcUsagePath   = ghc_usage_msg_path
      , fileSettings_ghciUsagePath  = ghci_usage_msg_path
      , fileSettings_toolDir        = mtool_dir
      , fileSettings_topDir         = top_dir
      , fileSettings_globalPackageDatabase = globalpkgdb_path
      }

    , sUnitSettings = UnitSettings
      {
        unitSettings_baseUnitId = stringToUnitId baseUnitId
      }

    , sToolSettings = ToolSettings
      { toolSettings_ldSupportsCompactUnwind = ccLinkSupportsCompactUnwind $ tgtCCompilerLink target
      , toolSettings_ldSupportsFilelist      = ccLinkSupportsFilelist      $ tgtCCompilerLink target
      , toolSettings_ldSupportsSingleModule  = ccLinkSupportsSingleModule  $ tgtCCompilerLink target
      , toolSettings_ldIsGnuLd               = ccLinkIsGnu                 $ tgtCCompilerLink target
      , toolSettings_ccSupportsNoPie         = ccLinkSupportsNoPie         $ tgtCCompilerLink target
      , toolSettings_mergeObjsSupportsResponseFiles
                                      = maybe False mergeObjsSupportsResponseFiles
                                                         $ tgtMergeObjs target
      , toolSettings_arSupportsDashL  = arSupportsDashL  $ tgtAr target
      , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 $ tgtCmmCPreprocessor target

      , toolSettings_pgm_L       = unlit_path
      , toolSettings_pgm_P       = (hs_cpp_prog, map Option hs_cpp_args)
      , toolSettings_pgm_JSP     = (js_cpp_prog, map Option js_cpp_args)
      , toolSettings_pgm_CmmP    = (cmmCpp_prog, map Option cmmCpp_args)
      , toolSettings_pgm_F       = ""
      , toolSettings_pgm_c       = cc_prog
      , toolSettings_pgm_cxx     = cxx_prog
      , toolSettings_pgm_cpp     = (cpp_prog, map Option cpp_args)
      , toolSettings_pgm_a       = (as_prog, as_args)
      , toolSettings_pgm_l       = (ld_prog, ld_args)
      , toolSettings_pgm_lm      = ld_r
      , toolSettings_pgm_windres = getMaybeToolPath tgtWindres
      , toolSettings_pgm_ar      = getToolPath (arMkArchive . tgtAr)
      , toolSettings_pgm_otool   = getMaybeToolPath tgtOtool
      , toolSettings_pgm_install_name_tool = getMaybeToolPath tgtInstallNameTool
      , toolSettings_pgm_ranlib  = getMaybeToolPath (fmap ranlibProgram . tgtRanlib)
      , toolSettings_pgm_lo      = (getMaybeToolPath tgtOpt,[])
      , toolSettings_pgm_lc      = (getMaybeToolPath tgtLlc,[])
      , toolSettings_pgm_las     = second (map Option) $
                                   getTool (fromMaybe (Program "" []) . tgtLlvmAs)
      , toolSettings_pgm_i       = iserv_prog
      , toolSettings_opt_L       = []
      , toolSettings_opt_P       = []
      , toolSettings_opt_JSP     = []
      , toolSettings_opt_CmmP    = []
      , toolSettings_opt_P_fingerprint   = fingerprint0
      , toolSettings_opt_JSP_fingerprint = fingerprint0
      , toolSettings_opt_CmmP_fingerprint = fingerprint0
      , toolSettings_opt_F       = []
      , toolSettings_opt_c       = cc_args
      , toolSettings_opt_cxx     = cxx_args
      , toolSettings_opt_a       = []
      , toolSettings_opt_l       = []
      , toolSettings_opt_lm      = []
      , toolSettings_opt_windres = []
      , toolSettings_opt_lo      = []
      , toolSettings_opt_lc      = []
      , toolSettings_opt_las     = []
      , toolSettings_opt_i       = []

      , toolSettings_extraGccViaCFlags = extraGccViaCFlags
      }

    , sTargetPlatform = platform
    , sPlatformMisc = PlatformMisc
      { platformMisc_targetPlatformString = targetPlatformTriple target
      , platformMisc_ghcWithInterpreter = ghcWithInterpreter
      , platformMisc_libFFI = tgtUseLibffiForAdjustors target
      , platformMisc_llvmTarget = tgtLlvmTarget target
      , platformMisc_targetRTSLinkerOnlySupportsSharedLibs = tgtRTSLinkerOnlySupportsSharedLibs target
      }

    , sRawSettings    = settingsList
    , sRawTarget      = target
    }

getTargetPlatform :: Target -> Platform
getTargetPlatform :: Target -> Platform
getTargetPlatform Target{Bool
String
Maybe String
Maybe Library
Maybe Program
Maybe Ranlib
Maybe MergeObjs
Maybe JsCpp
ByteOrder
ArchOS
Nm
Cxx
Cc
CcLink
CmmCpp
HsCpp
Cpp
Ar
WordSize
tgtCCompiler :: Target -> Cc
tgtCxxCompiler :: Target -> Cxx
tgtCPreprocessor :: Target -> Cpp
tgtHsCPreprocessor :: Target -> HsCpp
tgtJsCPreprocessor :: Target -> Maybe JsCpp
tgtCmmCPreprocessor :: Target -> CmmCpp
tgtCCompilerLink :: Target -> CcLink
tgtMergeObjs :: Target -> Maybe MergeObjs
tgtAr :: Target -> Ar
tgtWindres :: Target -> Maybe Program
tgtOtool :: Target -> Maybe Program
tgtInstallNameTool :: Target -> Maybe Program
tgtRanlib :: Target -> Maybe Ranlib
tgtOpt :: Target -> Maybe Program
tgtLlc :: Target -> Maybe Program
tgtLlvmAs :: Target -> Maybe Program
tgtUseLibffiForAdjustors :: Target -> Bool
tgtLlvmTarget :: Target -> String
tgtArchOs :: ArchOS
tgtVendor :: Maybe String
tgtLocallyExecutable :: Bool
tgtSupportsGnuNonexecStack :: Bool
tgtSupportsSubsectionsViaSymbols :: Bool
tgtSupportsIdentDirective :: Bool
tgtWordSize :: WordSize
tgtEndianness :: ByteOrder
tgtSymbolsHaveLeadingUnderscore :: Bool
tgtLlvmTarget :: String
tgtUnregisterised :: Bool
tgtTablesNextToCode :: Bool
tgtUseLibffiForAdjustors :: Bool
tgtHasLibm :: Bool
tgtRTSWithLibdw :: Maybe Library
tgtCCompiler :: Cc
tgtCxxCompiler :: Cxx
tgtCPreprocessor :: Cpp
tgtHsCPreprocessor :: HsCpp
tgtJsCPreprocessor :: Maybe JsCpp
tgtCmmCPreprocessor :: CmmCpp
tgtCCompilerLink :: CcLink
tgtAr :: Ar
tgtRanlib :: Maybe Ranlib
tgtNm :: Nm
tgtMergeObjs :: Maybe MergeObjs
tgtLlc :: Maybe Program
tgtOpt :: Maybe Program
tgtLlvmAs :: Maybe Program
tgtWindres :: Maybe Program
tgtOtool :: Maybe Program
tgtInstallNameTool :: Maybe Program
tgtNm :: Target -> Nm
tgtRTSWithLibdw :: Target -> Maybe Library
tgtHasLibm :: Target -> Bool
tgtTablesNextToCode :: Target -> Bool
tgtUnregisterised :: Target -> Bool
tgtSymbolsHaveLeadingUnderscore :: Target -> Bool
tgtEndianness :: Target -> ByteOrder
tgtWordSize :: Target -> WordSize
tgtSupportsIdentDirective :: Target -> Bool
tgtSupportsSubsectionsViaSymbols :: Target -> Bool
tgtSupportsGnuNonexecStack :: Target -> Bool
tgtLocallyExecutable :: Target -> Bool
tgtVendor :: Target -> Maybe String
tgtArchOs :: Target -> ArchOS
..} = Platform
    { platformArchOS :: ArchOS
platformArchOS    = ArchOS
tgtArchOs
    , platformWordSize :: PlatformWordSize
platformWordSize  = case WordSize
tgtWordSize of WordSize
WS4 -> PlatformWordSize
PW4
                                              WordSize
WS8 -> PlatformWordSize
PW8
    , platformByteOrder :: ByteOrder
platformByteOrder = ByteOrder
tgtEndianness
    , platformUnregisterised :: Bool
platformUnregisterised = Bool
tgtUnregisterised
    , platformHasGnuNonexecStack :: Bool
platformHasGnuNonexecStack = Bool
tgtSupportsGnuNonexecStack
    , platformHasIdentDirective :: Bool
platformHasIdentDirective = Bool
tgtSupportsIdentDirective
    , platformHasSubsectionsViaSymbols :: Bool
platformHasSubsectionsViaSymbols = Bool
tgtSupportsSubsectionsViaSymbols
    , platformIsCrossCompiling :: Bool
platformIsCrossCompiling = Bool -> Bool
not Bool
tgtLocallyExecutable
    , platformLeadingUnderscore :: Bool
platformLeadingUnderscore = Bool
tgtSymbolsHaveLeadingUnderscore
    , platformTablesNextToCode :: Bool
platformTablesNextToCode  = Bool
tgtTablesNextToCode
    , platformHasLibm :: Bool
platformHasLibm = Bool
tgtHasLibm
    , platform_constants :: Maybe PlatformConstants
platform_constants = Maybe PlatformConstants
forall a. Maybe a
Nothing -- will be filled later when loading (or building) the RTS unit
    }