Internal.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.GHC.Internal
-- Copyright   :  Isaac Jones 2003-2007
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module contains functions shared by GHC (Distribution.Simple.GHC)
-- and GHC-derived compilers.
module Distribution.Simple.GHC.Internal
  ( configureToolchain
  , getLanguages
  , getExtensions
  , targetPlatform
  , getGhcInfo
  , componentGhcOptions
  , sourcesGhcOptions
  , mkGHCiLibName
  , mkGHCiProfLibName
  , filterGhciFlags
  , ghcLookupProperty
  , getHaskellObjects
  , mkGhcOptPackages
  , substTopDir
  , checkPackageDbEnvVar
  , profDetailLevelFlag
  , ghcOptionsSince
  , linkGhcOptions
  , optimizationCFlags
  , splitCandCxxOptions
  , SplitSource (..)

    -- * GHC platform and version strings
  , ghcArchString
  , ghcOsString
  , ghcPlatformAndVersionString

    -- * Constructing GHC environment files
  , GhcEnvironmentFileEntry (..)
  , writeGhcEnvironmentFile
  , simpleGhcEnvironmentFile
  , ghcEnvironmentFileName
  , renderGhcEnvironmentFile
  , renderGhcEnvironmentFileEntry
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Backpack
import Distribution.Compat.Stack
import Distribution.Lex
import qualified Distribution.ModuleName as ModuleName
import Distribution.Parsec (simpleParsec)
import Distribution.Pretty (prettyShow)
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag
import Distribution.Simple.GHC.ImplInfo
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.BuildInfo
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.GivenComponent
import qualified Distribution.Types.InstalledPackageInfo as IPI
import Distribution.Types.Library
import Distribution.Types.LocalBuildInfo
import Distribution.Types.ModuleRenaming
import Distribution.Types.PackageName
import Distribution.Types.TargetInfo
import Distribution.Types.UnitId
import Distribution.Types.Version
import Distribution.Utils.NubList (NubListR, toNubListR)
import Distribution.Utils.Path
import Distribution.Verbosity
import Language.Haskell.Extension
import System.Directory (listDirectory)
import System.Environment (getEnv)
import System.FilePath
  ( takeDirectory
  , takeExtension
  , takeFileName
  )
import System.IO (hClose, hPutStrLn)

targetPlatform :: [(String, String)] -> Maybe Platform
targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo

-- | Adjust the way we find and configure gcc and ld
configureToolchain
  :: GhcImplInfo
  -> ConfiguredProgram
  -> Map String String
  -> ProgramDb
  -> ProgramDb
configureToolchain _implInfo ghcProg ghcInfo =
  addKnownProgram
    gccProgram
      { programFindLocation = findProg gccProgramName extraGccPath
      , programPostConf = configureGcc
      }
    . addKnownProgram
      gppProgram
        { programFindLocation = findProg gppProgramName extraGppPath
        , programPostConf = configureGpp
        }
    . addKnownProgram
      ldProgram
        { programFindLocation = findProg ldProgramName extraLdPath
        , programPostConf = \v cp ->
            -- Call any existing configuration first and then add any new configuration
            configureLd v =<< programPostConf ldProgram v cp
        }
    . addKnownProgram
      arProgram
        { programFindLocation = findProg arProgramName extraArPath
        }
    . addKnownProgram
      stripProgram
        { programFindLocation = findProg stripProgramName extraStripPath
        }
  where
    compilerDir, base_dir, mingwBinDir :: FilePath
    compilerDir = takeDirectory (programPath ghcProg)
    base_dir = takeDirectory compilerDir
    mingwBinDir = base_dir </> "mingw" </> "bin"
    isWindows = case buildOS of Windows -> True; _ -> False
    binPrefix = ""

    maybeName :: Program -> Maybe FilePath -> String
    maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName)

    gccProgramName = maybeName gccProgram mbGccLocation
    gppProgramName = maybeName gppProgram mbGppLocation
    ldProgramName = maybeName ldProgram mbLdLocation
    arProgramName = maybeName arProgram mbArLocation
    stripProgramName = maybeName stripProgram mbStripLocation

    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
    mkExtraPath mbPath mingwPath
      | isWindows = mbDir ++ [mingwPath]
      | otherwise = mbDir
      where
        mbDir = maybeToList . fmap takeDirectory $ mbPath

    extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir
    extraGppPath = mkExtraPath mbGppLocation windowsExtraGppDir
    extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir
    extraArPath = mkExtraPath mbArLocation windowsExtraArDir
    extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir

    -- on Windows finding and configuring ghc's gcc & binutils is a bit special
    ( windowsExtraGccDir
      , windowsExtraGppDir
      , windowsExtraLdDir
      , windowsExtraArDir
      , windowsExtraStripDir
      ) =
        let b = mingwBinDir </> binPrefix
         in (b, b, b, b, b)

    findProg
      :: String
      -> [FilePath]
      -> Verbosity
      -> ProgramSearchPath
      -> IO (Maybe (FilePath, [FilePath]))
    findProg progName extraPath v searchpath =
      findProgramOnSearchPath v searchpath' progName
      where
        searchpath' = map ProgramSearchPathDir extraPath ++ searchpath

    -- Read tool locations from the 'ghc --info' output. Useful when
    -- cross-compiling.
    mbGccLocation = Map.lookup "C compiler command" ghcInfo
    mbGppLocation = Map.lookup "C++ compiler command" ghcInfo
    mbLdLocation = Map.lookup "ld command" ghcInfo
    mbArLocation = Map.lookup "ar command" ghcInfo
    mbStripLocation = Map.lookup "strip command" ghcInfo

    ccFlags = getFlags "C compiler flags"
    cxxFlags = getFlags "C++ compiler flags"
    gccLinkerFlags = getFlags "C compiler link flags"
    ldLinkerFlags = getFlags "ld flags"

    -- It appears that GHC 7.6 and earlier encode the tokenized flags as a
    -- [String] in these settings whereas later versions just encode the flags as
    -- String.
    --
    -- We first try to parse as a [String] and if this fails then tokenize the
    -- flags ourself.
    getFlags :: String -> [String]
    getFlags key =
      case Map.lookup key ghcInfo of
        Nothing -> []
        Just flags
          | (flags', "") : _ <- reads flags -> flags'
          | otherwise -> tokenizeQuotedWords flags

    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureGcc _v gccProg = do
      return
        gccProg
          { programDefaultArgs =
              programDefaultArgs gccProg
                ++ ccFlags
                ++ gccLinkerFlags
          }

    configureGpp :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureGpp _v gppProg = do
      return
        gppProg
          { programDefaultArgs =
              programDefaultArgs gppProg
                ++ cxxFlags
          }

    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureLd v ldProg = do
      ldProg' <- configureLd' v ldProg
      return
        ldProg'
          { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
          }

    -- we need to find out if ld supports the -x flag
    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureLd' verbosity ldProg = do
      ldx <- withTempFile ".c" $ \testcfile testchnd ->
        withTempFile ".o" $ \testofile testohnd -> do
          hPutStrLn testchnd "int foo() { return 0; }"
          hClose testchnd
          hClose testohnd
          runProgram
            verbosity
            ghcProg
            [ "-hide-all-packages"
            , "-c"
            , testcfile
            , "-o"
            , testofile
            ]
          withTempFile ".o" $ \testofile' testohnd' ->
            do
              hClose testohnd'
              _ <-
                getProgramOutput
                  verbosity
                  ldProg
                  ["-x", "-r", testofile, "-o", testofile']
              return True
              `catchIO` (\_ -> return False)
              `catchExit` (\_ -> return False)
      if ldx
        then return ldProg{programDefaultArgs = ["-x"]}
        else return ldProg

getLanguages
  :: GhcImplInfo
  -> IO [(Language, String)]
getLanguages implInfo
  -- TODO: should be using --supported-languages rather than hard coding
  | supportsGHC2024 implInfo =
      return
        [ (GHC2024, "-XGHC2024")
        , (GHC2021, "-XGHC2021")
        , (Haskell2010, "-XHaskell2010")
        , (Haskell98, "-XHaskell98")
        ]
  | supportsGHC2021 implInfo =
      return
        [ (GHC2021, "-XGHC2021")
        , (Haskell2010, "-XHaskell2010")
        , (Haskell98, "-XHaskell98")
        ]
  | otherwise =
      return
        [ (Haskell98, "-XHaskell98")
        , (Haskell2010, "-XHaskell2010")
        ]

getGhcInfo
  :: Verbosity
  -> GhcImplInfo
  -> ConfiguredProgram
  -> IO [(String, String)]
getGhcInfo verbosity _implInfo ghcProg = do
  xs <-
    getProgramOutput
      verbosity
      (suppressOverrideArgs ghcProg)
      ["--info"]
  case reads xs of
    [(i, ss)]
      | all isSpace ss ->
          return i
    _ ->
      dieWithException verbosity CantParseGHCOutput

getExtensions
  :: Verbosity
  -> ConfiguredProgram
  -> IO [(Extension, Maybe String)]
getExtensions verbosity ghcProg = do
  str <-
    getProgramOutput
      verbosity
      (suppressOverrideArgs ghcProg)
      ["--supported-languages"]
  return
    [ (ext, Just $ "-X" ++ prettyShow ext)
    | Just ext <- map simpleParsec $ lines str
    ]

includePaths
  :: LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg p
  -> NubListR (SymbolicPath Pkg (Dir Include))
includePaths lbi bi clbi odir =
  toNubListR $
    [ coerceSymbolicPath $ autogenComponentModulesDir lbi clbi
    , coerceSymbolicPath $ autogenPackageModulesDir lbi
    , coerceSymbolicPath odir
    ]
      -- includes relative to the package
      ++ includeDirs bi
      -- potential includes generated by `configure'
      -- in the build directory
      ++ [ buildDir lbi </> dir
         | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi
         ]

data SplitSource = CcProgram | CxxProgram

splitCandCxxOptions
  :: SplitSource
  -> VerbosityLevel
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir Artifacts)
  -> SymbolicPath Pkg File
  -> GhcOptions
splitCandCxxOptions source verbosity lbi bi clbi odir filename = case source of
  CxxProgram ->
    -- For C++ sources: reset ccOptions for GHC < 8.10, because on those
    -- old GHCs there's no -optcxx flag — all options go through -optc.
    -- Without this reset, C-specific flags (ccOptions) would leak into
    -- C++ compilation via -optc, which is wrong.
    setGppProgram $ setCcOptions $ sourcesGhcOptions verbosity lbi bi clbi odir filename
  CcProgram ->
    -- For C sources: reset cxxOptions for GHC < 8.10, because on those
    -- old GHCs there's no -optcxx flag — all options go through -optc.
    -- Without this reset, C++-specific flags (cxxOptions) would leak into
    -- C compilation via -optc, which is wrong.
    setCcProgram $ setCxxOptions $ sourcesGhcOptions verbosity lbi bi clbi odir filename
  where
    setCcOptions xxx =
      xxx
        { -- C compiler options: GHC >= 8.10 requires -optcxx, older requires -optc
          -- we want to be able to support cxx-options and cc-options separately
          -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477
          -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsCxx
          ghcOptCcOptions =
            ghcOptionsSince
              (mkVersion [8, 10])
              (compiler lbi)
              (optimizationCFlags lbi ++ ccOptions bi)
        }
    setCxxOptions xxx =
      xxx
        { -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc
          -- we want to be able to support cxx-options and cc-options separately
          -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477
          -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsC
          ghcOptCxxOptions =
            ghcOptionsSince
              (mkVersion [8, 10])
              (compiler lbi)
              (optimizationCFlags lbi ++ cxxOptions bi)
        }
    setCcProgram xxx =
      xxx
        { -- We pass -pgmc to ensure that GHC respects cc-options and ld-options (#4435, #9801).
          -- However, we deliberately restrict this flag ONLY to C and C++ source files.
          -- We do not pass it globally (e.g., during linking or ordinary Haskell compilation)
          -- for two reasons:
          -- 1. Status quo: This preserves Cabal's historical behavior.
          -- 2. GHC < 9.4 bug (https://gitlab.haskell.org/ghc/ghc/-/issues/15319): Before GHC 9.4,
          --    passing a custom C compiler via -pgmc caused GHC to automatically disable the
          --    -no-pie flag (which is critical during linking on auto-hardened toolchains).
          --    Passing -pgmc globally would therefore break linking on older GHCs.
          --    https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6949 fixed this by moving
          --    the -no-pie check to -pgml, but scoping -pgmc exclusively to C/C++ compilation
          --    protects older GHC versions from this link-time breakage.
          -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsPgmc
          ghcOptCcProgram = maybeToFlag $ programPath <$> lookupProgram gccProgram (withPrograms lbi)
        }
    setGppProgram xxx =
      xxx
        { -- We explicitly pass the C++ compiler via -pgmcxx because GHC >= 9.4
          -- does not automatically detect it from the toolchain. Without this GHC
          -- falls back to a gcc as a C++ compiler.
          -- Related: #11805
          ghcOptGppProgram =
            ghcOptionsSince
              (mkVersion [9, 4])
              (compiler lbi)
              (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi))
        , -- For GHC < 9.4, which does not support -pgmcxx, we fall back to
          -- passing the C++ compiler via -pgmc. This ensures C++ sources are
          -- compiled with the correct compiler even on older GHCs.
          -- Note: we use gppProgram (C++ compiler), NOT gccProgram (C compiler),
          -- because this path is specifically for C++ source files.
          -- Related: #11805
          ghcOptCcProgram =
            ghcOptionsBefore
              (mkVersion [9, 4])
              (compiler lbi)
              (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi))
        }

sourcesGhcOptions
  :: VerbosityLevel
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir Artifacts)
  -> SymbolicPath Pkg File
  -> GhcOptions
sourcesGhcOptions verbosity lbi bi clbi odir filename =
  (componentGhcOptions verbosity lbi bi clbi odir)
    { ghcOptVerbosity = toFlag (min verbosity Normal)
    , ghcOptMode = toFlag GhcModeCompile
    , ghcOptInputFiles = toNubListR [filename]
    , ghcOptObjDir = toFlag odir
    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
    , -- cpp-options apply only to .hs files; GHC ignores -optP for non-Haskell
      -- files (and since 9.10 this behavior is explicit/enforced)
      ghcOptCppOptions = []
    }

optimizationCFlags :: LocalBuildInfo -> [String]
optimizationCFlags lbi =
  ( case withOptimization lbi of
      -- see --disable-optimization
      NoOptimisation -> []
      -- '*-options: -O[n]' is generally not needed. When building with
      -- optimisations Cabal automatically adds '-O2' for * code. Setting it
      -- yourself interferes with the --disable-optimization flag.
      -- see https://github.com/haskell/cabal/pull/8250
      NormalOptimisation -> ["-O2"]
      -- see --enable-optimization
      MaximumOptimisation -> ["-O2"]
  )
    ++ ( case withDebugInfo lbi of
          NoDebugInfo -> []
          MinimalDebugInfo -> ["-g1"]
          NormalDebugInfo -> ["-g"]
          MaximalDebugInfo -> ["-g3"]
       )

-- Applies options only if the GHC version is greater than or
-- equal to the given one.
ghcOptionsSince :: Monoid a => Version -> Compiler -> a -> a
ghcOptionsSince ver comp defOptions =
  case compilerCompatVersion GHC comp of
    Just v
      | v >= ver -> defOptions
      | otherwise -> mempty
    Nothing -> mempty

-- Applies options only if the GHC version is less than the given one.
ghcOptionsBefore :: Monoid a => Version -> Compiler -> a -> a
ghcOptionsBefore ver comp defOptions =
  case compilerCompatVersion GHC comp of
    Just v
      | v < ver -> defOptions
      | otherwise -> mempty
    Nothing -> mempty

componentGhcOptions
  :: VerbosityLevel
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir build)
  -> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
  let implInfo = getImplInfo $ compiler lbi
   in (linkGhcOptions verbosity lbi bi clbi)
        { ghcOptSourcePath =
            toNubListR $
              hsSourceDirs bi
                ++ [coerceSymbolicPath odir]
                ++ [autogenComponentModulesDir lbi clbi]
                ++ [autogenPackageModulesDir lbi]
        , ghcOptCppIncludePath = includePaths lbi bi clbi odir
        , ghcOptObjDir = toFlag $ coerceSymbolicPath odir
        , ghcOptHiDir = toFlag $ coerceSymbolicPath odir
        , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir </> (extraCompilationArtifacts </> makeRelativePathEx "hie")) $ flagHie implInfo
        , ghcOptStubDir = toFlag $ coerceSymbolicPath odir
        , ghcOptOutputDir = toFlag $ coerceSymbolicPath odir
        , ghcOptBytecodeDir = toFlag $ coerceSymbolicPath odir
        }

linkGhcOptions
  :: VerbosityLevel
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> GhcOptions
linkGhcOptions verbosity lbi bi clbi =
  let implInfo = getImplInfo $ compiler lbi
   in mempty
        { -- Respect -v0, but don't crank up verbosity on GHC if
          -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
          ghcOptVerbosity = toFlag (min verbosity Normal)
        , ghcOptCcOptions = ccOptions bi
        , ghcOptCxxOptions = cxxOptions bi
        , ghcOptAsmOptions = asmOptions bi
        , ghcOptLinkOptions = ldOptions bi
        , ghcOptCppOptions = cppOptions bi
        , ghcOptJSppOptions = jsppOptions bi
        , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi
        , ghcOptCabal = toFlag True
        , ghcOptThisUnitId = case clbi of
            LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
              toFlag pk
            _ | not (unitIdForExes implInfo) -> mempty
            ExeComponentLocalBuildInfo{componentUnitId = uid} ->
              toFlag (unUnitId uid)
            TestComponentLocalBuildInfo{componentUnitId = uid} ->
              toFlag (unUnitId uid)
            BenchComponentLocalBuildInfo{componentUnitId = uid} ->
              toFlag (unUnitId uid)
            FLibComponentLocalBuildInfo{componentUnitId = uid} ->
              toFlag (unUnitId uid)
        , ghcOptThisComponentId = case clbi of
            LibComponentLocalBuildInfo
              { componentComponentId = cid
              , componentInstantiatedWith = insts
              } ->
                if null insts
                  then mempty
                  else toFlag cid
            _ -> mempty
        , ghcOptInstantiatedWith = case clbi of
            LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
              insts
            _ -> []
        , ghcOptNoCode = toFlag $ componentIsIndefinite clbi
        , ghcOptHideAllPackages = toFlag True
        , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo
        , ghcOptPackageDBs = withPackageDB lbi
        , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi
        , ghcOptSplitSections = toFlag (splitSections lbi)
        , ghcOptSplitObjs = toFlag (splitObjs lbi)
        , ghcOptSourcePathClear = toFlag True
        , ghcOptCppIncludes =
            toNubListR [coerceSymbolicPath (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]
        , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi
        , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
        , ghcOptDebugInfo = toFlag (withDebugInfo lbi)
        , ghcOptExtraPath = toNubListR exe_paths
        , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi))
        , -- Unsupported extensions have already been checked by configure
          ghcOptExtensions = toNubListR $ usedExtensions bi
        , ghcOptExtensionMap = Map.fromList . compilerExtensions $ compiler lbi
        , -- Use -pgmc to ensure that Cabal always passes cc-options, ld-options to GHC (#4435, #9801)
          -- We can only do this on GHC >= 9.4, as we need https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6949
          -- Without that GHC MR, this change would cause GHC to never pass -no-pie when linking,
          -- which can cause breakage depending on the C toolchain use. We would have to appropriately
          -- pass -pgmc-supports-no-pie as appropriate to avoid this regression.
          ghcOptCcProgram =
            ghcOptionsSince
              (mkVersion [9, 4])
              (compiler lbi)
              (maybeToFlag $ programPath <$> lookupProgram gccProgram (withPrograms lbi))
        , -- The assumption that the C++ compiler is part of the toolchain is only since ghc-9.4.
          ghcOptGppProgram =
            ghcOptionsSince
              (mkVersion [9, 4])
              (compiler lbi)
              (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi))
        }
  where
    exe_paths =
      [ componentBuildDir lbi (targetCLBI exe_tgt)
      | uid <- componentExeDeps clbi
      , -- TODO: Ugh, localPkgDescr
      Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid]
      ]

toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation
toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override?
toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation

-- | Strip out flags that are not supported in ghci
filterGhciFlags :: [String] -> [String]
filterGhciFlags = filter supported
  where
    supported ('-' : 'O' : _) = False
    supported "-debug" = False
    supported "-threaded" = False
    supported "-ticky" = False
    supported "-eventlog" = False
    supported "-prof" = False
    supported "-unreg" = False
    supported _ = True

mkGHCiLibName :: UnitId -> String
mkGHCiLibName lib = getHSLibraryName lib <.> "o"

mkGHCiProfLibName :: UnitId -> String
mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o"

ghcLookupProperty :: String -> Compiler -> Bool
ghcLookupProperty prop comp =
  case Map.lookup prop (compilerProperties comp) of
    Just "YES" -> True
    _ -> False

-- when using -split-objs, we need to search for object files in the
-- Module_split directory for each module.
getHaskellObjects
  :: GhcImplInfo
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir Artifacts)
  -> String
  -> Bool
  -> IO [SymbolicPath Pkg File]
getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs
  | splitObjs lbi && allow_split_objs = do
      let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
          dirs =
            [ pref </> makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix)
            | x <- allLibModules lib clbi
            ]
      objss <- traverse (listDirectory . i) dirs
      let objs =
            [ dir </> makeRelativePathEx obj
            | (objs', dir) <- zip objss dirs
            , obj <- objs'
            , let obj_ext = takeExtension obj
            , '.' : wanted_obj_ext == obj_ext
            ]
      return objs
  | otherwise =
      return
        [ pref </> makeRelativePathEx (ModuleName.toFilePath x <.> wanted_obj_ext)
        | x <- allLibModules lib clbi
        ]
  where
    i = interpretSymbolicPathLBI lbi

-- | Create the required packaged arguments, but filtering out package arguments which
-- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files,
-- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that
-- in 99% of cases we will include the right `-package` so that the C file finds the right headers.
mkGhcOptPackages
  :: Map (PackageName, ComponentName) PromisedComponent
  -> ComponentLocalBuildInfo
  -> [(OpenUnitId, ModuleRenaming)]
mkGhcOptPackages promisedPkgsMap clbi =
  [ i | i@(uid, _) <- componentIncludes clbi, abstractUnitId uid `Set.notMember` promised_cids
  ]
  where
    -- Promised deps are going to be simple UnitIds
    promised_cids = Set.fromList (map (newSimpleUnitId . promisedComponentId) (Map.elems promisedPkgsMap))

substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo
substTopDir topDir ipo =
  ipo
    { IPI.importDirs = map f (IPI.importDirs ipo)
    , IPI.libraryDirs = map f (IPI.libraryDirs ipo)
    , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo)
    , IPI.includeDirs = map f (IPI.includeDirs ipo)
    , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo)
    , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo)
    , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo)
    }
  where
    f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest
    f x = x

-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let
-- users know that this is the case. See ticket #335. Simply ignoring it is
-- not a good idea, since then ghc and cabal are looking at different sets
-- of package DBs and chaos is likely to ensue.
--
-- An exception to this is when running cabal from within a `cabal exec`
-- environment. In this case, `cabal exec` will set the
-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set
-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow
-- GHC{,JS}_PACKAGE_PATH.
checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()
checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do
  mPP <- lookupEnv packagePathEnvVar
  when (isJust mPP) $ do
    mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
    unless (mPP == mcsPP) abort
  where
    lookupEnv :: String -> IO (Maybe String)
    lookupEnv name =
      (Just `fmap` getEnv name)
        `catchIO` const (return Nothing)
    abort =
      dieWithException verbosity $ IncompatibleWithCabal compilerName packagePathEnvVar
    _ = callStack -- TODO: output stack when erroring

profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
profDetailLevelFlag forLib mpl =
  case mpl of
    ProfDetailNone -> mempty
    ProfDetailDefault
      | forLib -> toFlag GhcProfAutoExported
      | otherwise -> toFlag GhcProfAutoToplevel
    ProfDetailExportedFunctions -> toFlag GhcProfAutoExported
    ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel
    ProfDetailAllFunctions -> toFlag GhcProfAutoAll
    ProfDetailTopLate -> toFlag GhcProfLate
    ProfDetailOther _ -> mempty

-- -----------------------------------------------------------------------------
-- GHC platform and version strings

-- | GHC's rendering of its host or target 'Arch' as used in its platform
-- strings and certain file locations (such as user package db location).
ghcArchString :: Arch -> String
ghcArchString PPC = "powerpc"
ghcArchString PPC64 = "powerpc64"
ghcArchString PPC64LE = "powerpc64le"
ghcArchString other = prettyShow other

-- | GHC's rendering of its host or target 'OS' as used in its platform
-- strings and certain file locations (such as user package db location).
ghcOsString :: OS -> String
ghcOsString Windows = "mingw32"
ghcOsString OSX = "darwin"
ghcOsString Solaris = "solaris2"
ghcOsString Hurd = "gnu"
ghcOsString other = prettyShow other

-- | GHC's rendering of its platform and compiler version string as used in
-- certain file locations (such as user package db location).
-- For example @x86_64-linux-7.10.4@
ghcPlatformAndVersionString :: Platform -> Version -> String
ghcPlatformAndVersionString (Platform arch os) version =
  intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version]

-- -----------------------------------------------------------------------------
-- Constructing GHC environment files

-- | The kinds of entries we can stick in a @.ghc.environment@ file.
data GhcEnvironmentFileEntry fp
  = -- | @-- a comment@
    GhcEnvFileComment String
  | -- | @package-id foo-1.0-4fe301a...@
    GhcEnvFilePackageId UnitId
  | -- | @global-package-db@,
    --   @user-package-db@ or
    --   @package-db blah/package.conf.d/@
    GhcEnvFilePackageDb (PackageDBX fp)
  | -- | @clear-package-db@
    GhcEnvFileClearPackageDbStack
  deriving (Eq, Ord, Show)

-- | Make entries for a GHC environment file based on a 'PackageDBStack' and
-- a bunch of package (unit) ids.
--
-- If you need to do anything more complicated then either use this as a basis
-- and add more entries, or just make all the entries directly.
simpleGhcEnvironmentFile
  :: PackageDBStackX fp
  -> [UnitId]
  -> [GhcEnvironmentFileEntry fp]
simpleGhcEnvironmentFile packageDBs pkgids =
  GhcEnvFileClearPackageDbStack
    : map GhcEnvFilePackageDb packageDBs
    ++ map GhcEnvFilePackageId pkgids

-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory.
--
-- The 'Platform' and GHC 'Version' are needed as part of the file name.
--
-- Returns the name of the file written.
writeGhcEnvironmentFile
  :: FilePath
  -- ^ directory in which to put it
  -> Platform
  -- ^ the GHC target platform
  -> Version
  -- ^ the GHC version
  -> [GhcEnvironmentFileEntry FilePath]
  -- ^ the content
  -> IO FilePath
writeGhcEnvironmentFile directory platform ghcversion entries = do
  writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries
  return envfile
  where
    envfile = directory </> ghcEnvironmentFileName platform ghcversion

-- | The @.ghc.environment-$arch-$os-$ver@ file name
ghcEnvironmentFileName :: Platform -> Version -> FilePath
ghcEnvironmentFileName platform ghcversion =
  ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion

-- | Render a bunch of GHC environment file entries
renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry FilePath] -> String
renderGhcEnvironmentFile =
  unlines . map renderGhcEnvironmentFileEntry

-- | Render an individual GHC environment file entry
renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry FilePath -> String
renderGhcEnvironmentFileEntry entry = case entry of
  GhcEnvFileComment comment -> format comment
    where
      format = intercalate "\n" . map ("--" <++>) . lines
      pref <++> "" = pref
      pref <++> str = pref ++ " " ++ str
  GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid
  GhcEnvFilePackageDb pkgdb ->
    case pkgdb of
      GlobalPackageDB -> "global-package-db"
      UserPackageDB -> "user-package-db"
      SpecificPackageDB dbfile -> "package-db " ++ dbfile
  GhcEnvFileClearPackageDbStack -> "clear-package-db"