Cabal/src/Distribution/Simple/Program/GHC.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE MultiWayIf #-}
   5 {-# LANGUAGE RankNTypes #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TypeApplications #-}
   9
  10 module Distribution.Simple.Program.GHC
  11   ( GhcOptions (..)
  12   , GhcMode (..)
  13   , GhcOptimisation (..)
  14   , GhcDynLinkMode (..)
  15   , GhcProfAuto (..)
  16   , ghcInvocation
  17   , renderGhcOptions
  18   , runGHC
  19   , packageDbArgsDb
  20   , normaliseGhcArgs
  21   ) where
  22
  23 import Distribution.Compat.Prelude
  24 import Prelude ()
  25
  26 import Distribution.Backpack
  27 import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..))
  28 import Distribution.ModuleName
  29 import Distribution.PackageDescription
  30 import Distribution.Pretty
  31 import Distribution.Simple.Compiler
  32 import Distribution.Simple.Flag
  33 import Distribution.Simple.GHC.ImplInfo
  34 import Distribution.Simple.Program.Find (getExtraPathEnv)
  35 import Distribution.Simple.Program.Run
  36 import Distribution.Simple.Program.Types
  37 import Distribution.System
  38 import Distribution.Types.ComponentId
  39 import Distribution.Types.ParStrat
  40 import Distribution.Utils.NubList
  41 import Distribution.Utils.Path
  42 import Distribution.Verbosity
  43 import Distribution.Version
  44
  45 import Language.Haskell.Extension
  46
  47 import Data.List (stripPrefix)
  48 import qualified Data.Map as Map
  49 import Data.Monoid (All (..), Any (..), Endo (..))
  50 import qualified Data.Set as Set
  51
  52 normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String]
  53 normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
  54   | ghcVersion `withinRange` supportedGHCVersions =
  55       argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs
  56   where
  57     supportedGHCVersions :: VersionRange
  58     supportedGHCVersions = orLaterVersion (mkVersion [8, 0])
  59     -- we (weakly) support unknown future GHC versions for the purpose
  60     -- of filtering GHC arguments
  61
  62     from :: Monoid m => [Int] -> m -> m
  63     from version flags
  64       | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags
  65       | otherwise = mempty
  66
  67     to :: Monoid m => [Int] -> m -> m
  68     to version flags
  69       | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags
  70       | otherwise = mempty
  71
  72     checkGhcFlags :: forall m. Monoid m => ([String] -> m) -> m
  73     checkGhcFlags fun =
  74       mconcat
  75         [ fun ghcArgs
  76         , checkComponentFlags libBuildInfo pkgLibs
  77         , checkComponentFlags buildInfo executables
  78         , checkComponentFlags testBuildInfo testSuites
  79         , checkComponentFlags benchmarkBuildInfo benchmarks
  80         ]
  81       where
  82         pkgLibs = maybeToList library ++ subLibraries
  83
  84         checkComponentFlags :: (a -> BuildInfo) -> [a] -> m
  85         checkComponentFlags getInfo = foldMap (checkComponent . getInfo)
  86           where
  87             checkComponent :: BuildInfo -> m
  88             checkComponent = foldMap fun . filterGhcOptions . allGhcOptions
  89
  90             allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])]
  91             allGhcOptions =
  92               foldMap
  93                 (perCompilerFlavorToList .)
  94                 [options, profOptions, sharedOptions, staticOptions]
  95
  96             filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]]
  97             filterGhcOptions l = [opts | (GHC, opts) <- l]
  98
  99     safeToFilterWarnings :: Bool
 100     safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings
 101       where
 102         checkWarnings :: [String] -> All
 103         checkWarnings = All . Set.null . foldr alter Set.empty
 104
 105         alter :: String -> Set String -> Set String
 106         alter flag =
 107           appEndo $
 108             mconcat
 109               [ \s -> Endo $ if s == "-Werror" then Set.insert s else id
 110               , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id
 111               , \s ->
 112                   from [8, 6] . Endo $
 113                     if s == "-Werror=compat"
 114                       then Set.union compatWarningSet
 115                       else id
 116               , \s ->
 117                   from [8, 6] . Endo $
 118                     if s == "-Wno-error=compat"
 119                       then (`Set.difference` compatWarningSet)
 120                       else id
 121               , \s ->
 122                   from [8, 6] . Endo $
 123                     if s == "-Wwarn=compat"
 124                       then (`Set.difference` compatWarningSet)
 125                       else id
 126               , from [8, 4] $ markFlag "-Werror=" Set.insert
 127               , from [8, 4] $ markFlag "-Wwarn=" Set.delete
 128               , from [8, 4] $ markFlag "-Wno-error=" Set.delete
 129               ]
 130               flag
 131
 132         markFlag
 133           :: String
 134           -> (String -> Set String -> Set String)
 135           -> String
 136           -> Endo (Set String)
 137         markFlag name update flag = Endo $ case stripPrefix name flag of
 138           Just rest | not (null rest) && rest /= "compat" -> update rest
 139           _ -> id
 140
 141     flagArgumentFilter :: [String] -> [String] -> [String]
 142     flagArgumentFilter flags = go
 143       where
 144         makeFilter :: String -> String -> Option' (First' ([String] -> [String]))
 145         makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg
 146           where
 147             filterRest leftOver = case dropEq leftOver of
 148               [] -> drop 1
 149               _ -> id
 150
 151         checkFilter :: String -> Maybe ([String] -> [String])
 152         checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags
 153
 154         go :: [String] -> [String]
 155         go [] = []
 156         go (arg : args) = case checkFilter arg of
 157           Just f -> go (f args)
 158           Nothing -> arg : go args
 159
 160     argumentFilters :: [String] -> [String]
 161     argumentFilters =
 162       flagArgumentFilter
 163         ["-ghci-script", "-H", "-interactive-print"]
 164
 165     filterRtsOpts :: [String] -> [String]
 166     filterRtsOpts = go False
 167       where
 168         go :: Bool -> [String] -> [String]
 169         go _ [] = []
 170         go _ ("+RTS" : opts) = go True opts
 171         go _ ("-RTS" : opts) = go False opts
 172         go isRTSopts (opt : opts) = addOpt $ go isRTSopts opts
 173           where
 174             addOpt
 175               | isRTSopts = id
 176               | otherwise = (opt :)
 177
 178     simpleFilters :: String -> Bool
 179     simpleFilters =
 180       not
 181         . getAny
 182         . mconcat
 183           [ flagIn simpleFlags
 184           , Any . isPrefixOf "-ddump-"
 185           , Any . isPrefixOf "-dsuppress-"
 186           , Any . isPrefixOf "-dno-suppress-"
 187           , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"]
 188           , flagIn . invertibleFlagSet "-f" . mconcat $
 189               [
 190                 [ "reverse-errors"
 191                 , "warn-unused-binds"
 192                 , "break-on-error"
 193                 , "break-on-exception"
 194                 , "print-bind-result"
 195                 , "print-bind-contents"
 196                 , "print-evld-with-show"
 197                 , "implicit-import-qualified"
 198                 , "error-spans"
 199                 ]
 200               , from
 201                   [7, 8]
 202                   [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options
 203                   , "print-explicit-kinds"
 204                   ]
 205               , from
 206                   [8, 0]
 207                   [ "print-explicit-coercions"
 208                   , "print-explicit-runtime-reps"
 209                   , "print-equality-relations"
 210                   , "print-unicode-syntax"
 211                   , "print-expanded-synonyms"
 212                   , "print-potential-instances"
 213                   , "print-typechecker-elaboration"
 214                   ]
 215               , from
 216                   [8, 2]
 217                   [ "diagnostics-show-caret"
 218                   , "local-ghci-history"
 219                   , "show-warning-groups"
 220                   , "hide-source-paths"
 221                   , "show-hole-constraints"
 222                   ]
 223               , from [8, 4] ["show-loaded-modules"]
 224               , from [8, 6] ["ghci-leak-check", "no-it"]
 225               , from
 226                   [8, 10]
 227                   [ "defer-diagnostics" -- affects printing of diagnostics
 228                   , "keep-going" -- try harder, the build will still fail if it's erroneous
 229                   , "print-axiom-incomps" -- print more debug info for closed type families
 230                   ]
 231               , from
 232                   [9, 2]
 233                   [ "family-application-cache"
 234                   ]
 235               , from
 236                   [9, 6]
 237                   [ "print-redundant-promotion-ticks"
 238                   , "show-error-context"
 239                   ]
 240               , from
 241                   [9, 8]
 242                   [ "unoptimized-core-for-interpreter"
 243                   ]
 244               , from
 245                   [9, 10]
 246                   [ "diagnostics-as-json"
 247                   , "print-error-index-links"
 248                   , "break-points"
 249                   ]
 250               ]
 251           , flagIn $ invertibleFlagSet "-d" ["ppr-case-as-let", "ppr-ticks"]
 252           , isOptIntFlag
 253           , isIntFlag
 254           , if safeToFilterWarnings
 255               then isWarning <> (Any . ("-w" ==))
 256               else mempty
 257           , from [8, 6] $
 258               if safeToFilterHoles
 259                 then isTypedHoleFlag
 260                 else mempty
 261           ]
 262
 263     flagIn :: Set String -> String -> Any
 264     flagIn set flag = Any $ Set.member flag set
 265
 266     isWarning :: String -> Any
 267     isWarning =
 268       mconcat $
 269         map
 270           ((Any .) . isPrefixOf)
 271           ["-fwarn-", "-fno-warn-", "-W", "-Wno-"]
 272
 273     simpleFlags :: Set String
 274     simpleFlags =
 275       Set.fromList . mconcat $
 276         [
 277           [ "-n"
 278           , "-#include"
 279           , "-Rghc-timing"
 280           , "-dstg-stats"
 281           , "-dth-dec-file"
 282           , "-dsource-stats"
 283           , "-dverbose-core2core"
 284           , "-dverbose-stg2stg"
 285           , "-dcore-lint"
 286           , "-dstg-lint"
 287           , "-dcmm-lint"
 288           , "-dasm-lint"
 289           , "-dannot-lint"
 290           , "-dshow-passes"
 291           , "-dfaststring-stats"
 292           , "-fno-max-relevant-binds"
 293           , "-recomp"
 294           , "-no-recomp"
 295           , "-fforce-recomp"
 296           , "-fno-force-recomp"
 297           ]
 298         , from
 299             [8, 2]
 300             [ "-fno-max-errors"
 301             , "-fdiagnostics-color=auto"
 302             , "-fdiagnostics-color=always"
 303             , "-fdiagnostics-color=never"
 304             , "-dppr-debug"
 305             , "-dno-debug-output"
 306             ]
 307         , from [8, 4] ["-ddebug-output"]
 308         , from [8, 4] $ to [8, 6] ["-fno-max-valid-substitutions"]
 309         , from [8, 6] ["-dhex-word-literals"]
 310         , from [8, 8] ["-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits"]
 311         , from [9, 0] ["-dlinear-core-lint"]
 312         , from [9, 10] ["-dipe-stats"]
 313         ]
 314
 315     isOptIntFlag :: String -> Any
 316     isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"]
 317
 318     isIntFlag :: String -> Any
 319     isIntFlag =
 320       mconcat . map (dropIntFlag False) . mconcat $
 321         [
 322           [ "-fmax-relevant-binds"
 323           , "-ddpr-user-length"
 324           , "-ddpr-cols"
 325           , "-dtrace-level"
 326           , "-fghci-hist-size"
 327           , "-dinitial-unique"
 328           , "-dunique-increment"
 329           ]
 330         , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"]
 331         , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"]
 332         , from [9, 12] ["-fmax-forced-spec-args", "-fwrite-if-compression"]
 333         ]
 334
 335     dropIntFlag :: Bool -> String -> String -> Any
 336     dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of
 337       Nothing -> False
 338       Just rest
 339         | isOpt && null rest -> True
 340         | otherwise -> case parseInt rest of
 341             Just _ -> True
 342             Nothing -> False
 343       where
 344         parseInt :: String -> Maybe Int
 345         parseInt = readMaybe . dropEq
 346
 347     dropEq :: String -> String
 348     dropEq ('=' : s) = s
 349     dropEq s = s
 350
 351     invertibleFlagSet :: String -> [String] -> Set String
 352     invertibleFlagSet prefix flagNames =
 353       Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames
 354
 355     compatWarningSet :: Set String
 356     compatWarningSet =
 357       Set.fromList $
 358         mconcat
 359           [ from
 360               [8, 6]
 361               [ "missing-monadfail-instances"
 362               , "semigroup"
 363               , "noncanonical-monoid-instances"
 364               , "implicit-kind-vars"
 365               ]
 366           ]
 367
 368     safeToFilterHoles :: Bool
 369     safeToFilterHoles =
 370       getAll . checkGhcFlags $
 371         All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred
 372       where
 373         notDeferred :: String -> Option' (Last' Bool)
 374         notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False
 375         notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True
 376         notDeferred _ = Option' Nothing
 377
 378     isTypedHoleFlag :: String -> Any
 379     isTypedHoleFlag =
 380       mconcat
 381         [ flagIn . invertibleFlagSet "-f" $
 382             [ "show-hole-constraints"
 383             , "show-valid-substitutions"
 384             , "show-valid-hole-fits"
 385             , "sort-valid-hole-fits"
 386             , "sort-by-size-hole-fits"
 387             , "sort-by-subsumption-hole-fits"
 388             , "abstract-refinement-hole-fits"
 389             , "show-provenance-of-hole-fits"
 390             , "show-hole-matches-of-hole-fits"
 391             , "show-type-of-hole-fits"
 392             , "show-type-app-of-hole-fits"
 393             , "show-type-app-vars-of-hole-fits"
 394             , "unclutter-valid-hole-fits"
 395             ]
 396         , flagIn . Set.fromList $
 397             [ "-fno-max-valid-hole-fits"
 398             , "-fno-max-refinement-hole-fits"
 399             , "-fno-refinement-level-hole-fits"
 400             ]
 401         , mconcat . map (dropIntFlag False) $
 402             [ "-fmax-valid-hole-fits"
 403             , "-fmax-refinement-hole-fits"
 404             , "-frefinement-level-hole-fits"
 405             ]
 406         ]
 407 normaliseGhcArgs _ _ args = args
 408
 409 -- | A structured set of GHC options/flags
 410 --
 411 -- Note that options containing lists fall into two categories:
 412 --
 413 --  * options that can be safely deduplicated, e.g. input modules or
 414 --    enabled extensions;
 415 --  * options that cannot be deduplicated in general without changing
 416 --    semantics, e.g. extra ghc options or linking options.
 417 data GhcOptions = GhcOptions
 418   { ghcOptMode :: Flag GhcMode
 419   -- ^ The major mode for the ghc invocation.
 420   , ghcOptExtra :: [String]
 421   -- ^ Any extra options to pass directly to ghc. These go at the end and hence
 422   -- override other stuff.
 423   , ghcOptExtraDefault :: [String]
 424   -- ^ Extra default flags to pass directly to ghc. These go at the beginning
 425   -- and so can be overridden by other stuff.
 426   , -----------------------
 427     -- Inputs and outputs
 428
 429     ghcOptInputFiles :: NubListR (SymbolicPath Pkg File)
 430   -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode.
 431   , ghcOptInputScripts :: NubListR (SymbolicPath Pkg File)
 432   -- ^ Script files with irregular extensions that need -x hs.
 433   , ghcOptInputModules :: NubListR ModuleName
 434   -- ^ The names of input Haskell modules, mainly for @--make@ mode.
 435   , ghcOptOutputFile :: Flag (SymbolicPath Pkg File)
 436   -- ^ Location for output file; the @ghc -o@ flag.
 437   , ghcOptOutputDynFile :: Flag FilePath
 438   -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode;
 439   -- the @ghc -dyno@ flag.
 440   , ghcOptSourcePathClear :: Flag Bool
 441   -- ^ Start with an empty search path for Haskell source files;
 442   -- the @ghc -i@ flag (@-i@ on its own with no path argument).
 443   , ghcOptSourcePath :: NubListR (SymbolicPath Pkg (Dir Source))
 444   -- ^ Search path for Haskell source files; the @ghc -i@ flag.
 445   , -------------
 446     -- Packages
 447
 448     ghcOptThisUnitId :: Flag String
 449   -- ^ The unit ID the modules will belong to; the @ghc -this-unit-id@
 450   -- flag (or @-this-package-key@ or @-package-name@ on older
 451   -- versions of GHC).  This is a 'String' because we assume you've
 452   -- already figured out what the correct format for this string is
 453   -- (we need to handle backwards compatibility.)
 454   , ghcOptThisComponentId :: Flag ComponentId
 455   -- ^ GHC doesn't make any assumptions about the format of
 456   -- definite unit ids, so when we are instantiating a package it
 457   -- needs to be told explicitly what the component being instantiated
 458   -- is.  This only gets set when 'ghcOptInstantiatedWith' is non-empty
 459   , ghcOptInstantiatedWith :: [(ModuleName, OpenModule)]
 460   -- ^ How the requirements of the package being compiled are to
 461   -- be filled.  When typechecking an indefinite package, the 'OpenModule'
 462   -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module
 463   -- that instantiates a package.
 464   , ghcOptNoCode :: Flag Bool
 465   -- ^ No code? (But we turn on interface writing
 466   , ghcOptPackageDBs :: PackageDBStack
 467   -- ^ GHC package databases to use, the @ghc -package-conf@ flag.
 468   , ghcOptPackages
 469       :: NubListR (OpenUnitId, ModuleRenaming)
 470   -- ^ The GHC packages to bring into scope when compiling,
 471   -- the @ghc -package-id@ flags.
 472   , ghcOptHideAllPackages :: Flag Bool
 473   -- ^ Start with a clean package set; the @ghc -hide-all-packages@ flag
 474   , ghcOptWarnMissingHomeModules :: Flag Bool
 475   -- ^ Warn about modules, not listed in command line
 476   , ghcOptNoAutoLinkPackages :: Flag Bool
 477   -- ^ Don't automatically link in Haskell98 etc; the @ghc
 478   -- -no-auto-link-packages@ flag.
 479   , -----------------
 480     -- Linker stuff
 481
 482     ghcOptLinkLibs :: [FilePath]
 483   -- ^ Names of libraries to link in; the @ghc -l@ flag.
 484   , ghcOptLinkLibPath :: NubListR (SymbolicPath Pkg (Dir Lib))
 485   -- ^ Search path for libraries to link in; the @ghc -L@ flag.
 486   , ghcOptLinkOptions :: [String]
 487   -- ^ Options to pass through to the linker; the @ghc -optl@ flag.
 488   , ghcOptLinkFrameworks :: NubListR String
 489   -- ^ OSX only: frameworks to link in; the @ghc -framework@ flag.
 490   , ghcOptLinkFrameworkDirs :: NubListR (SymbolicPath Pkg (Dir Framework))
 491   -- ^ OSX only: Search path for frameworks to link in; the
 492   -- @ghc -framework-path@ flag.
 493   , ghcOptLinkRts :: Flag Bool
 494   -- ^ Instruct GHC to link against @libHSrts@ when producing a shared library.
 495   , ghcOptNoLink :: Flag Bool
 496   -- ^ Don't do the link step, useful in make mode; the @ghc -no-link@ flag.
 497   , ghcOptLinkNoHsMain :: Flag Bool
 498   -- ^ Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@
 499   -- flag.
 500   , ghcOptLinkModDefFiles :: NubListR FilePath
 501   -- ^ Module definition files (Windows specific)
 502   , --------------------
 503     -- C and CPP stuff
 504
 505     ghcOptCcOptions :: [String]
 506   -- ^ Options to pass through to the C compiler; the @ghc -optc@ flag.
 507   , ghcOptCxxOptions :: [String]
 508   -- ^ Options to pass through to the C++ compiler.
 509   , ghcOptAsmOptions :: [String]
 510   -- ^ Options to pass through to the Assembler.
 511   , ghcOptCppOptions :: [String]
 512   -- ^ Options to pass through to CPP; the @ghc -optP@ flag.
 513   , ghcOptCppIncludePath :: NubListR (SymbolicPath Pkg (Dir Include))
 514   -- ^ Search path for CPP includes like header files; the @ghc -I@ flag.
 515   , ghcOptCppIncludes :: NubListR (SymbolicPath Pkg File)
 516   -- ^ Extra header files to include at CPP stage; the @ghc -optP-include@ flag.
 517   , ghcOptFfiIncludes :: NubListR FilePath
 518   -- ^ Extra header files to include for old-style FFI; the @ghc -#include@ flag.
 519   , ghcOptCcProgram :: Flag FilePath
 520   -- ^ Program to use for the C and C++ compiler; the @ghc -pgmc@ flag.
 521   , ----------------------------
 522     -- Language and extensions
 523
 524     ghcOptLanguage :: Flag Language
 525   -- ^ The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.
 526   , ghcOptExtensions :: NubListR Extension
 527   -- ^ The language extensions; the @ghc -X@ flag.
 528   , ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag)
 529   -- ^ A GHC version-dependent mapping of extensions to flags. This must be
 530   -- set to be able to make use of the 'ghcOptExtensions'.
 531   , ----------------
 532     -- Compilation
 533
 534     ghcOptOptimisation :: Flag GhcOptimisation
 535   -- ^ What optimisation level to use; the @ghc -O@ flag.
 536   , ghcOptDebugInfo :: Flag DebugInfoLevel
 537   -- ^ Emit debug info; the @ghc -g@ flag.
 538   , ghcOptProfilingMode :: Flag Bool
 539   -- ^ Compile in profiling mode; the @ghc -prof@ flag.
 540   , ghcOptProfilingAuto :: Flag GhcProfAuto
 541   -- ^ Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags.
 542   , ghcOptSplitSections :: Flag Bool
 543   -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag.
 544   , ghcOptSplitObjs :: Flag Bool
 545   -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag.
 546   , ghcOptNumJobs :: Flag ParStrat
 547   -- ^ Run N jobs simultaneously (if possible).
 548   , ghcOptHPCDir :: Flag (SymbolicPath Pkg (Dir Mix))
 549   -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.
 550   , ----------------
 551     -- GHCi
 552
 553     ghcOptGHCiScripts :: [FilePath]
 554   -- ^ Extra GHCi startup scripts; the @-ghci-script@ flag
 555   , ------------------------
 556     -- Redirecting outputs
 557
 558     ghcOptHiSuffix :: Flag String
 559   , ghcOptObjSuffix :: Flag String
 560   , ghcOptDynHiSuffix :: Flag String
 561   -- ^ only in 'GhcStaticAndDynamic' mode
 562   , ghcOptDynObjSuffix :: Flag String
 563   -- ^ only in 'GhcStaticAndDynamic' mode
 564   , ghcOptHiDir :: Flag (SymbolicPath Pkg (Dir Artifacts))
 565   , ghcOptHieDir :: Flag (SymbolicPath Pkg (Dir Artifacts))
 566   , ghcOptObjDir :: Flag (SymbolicPath Pkg (Dir Artifacts))
 567   , ghcOptOutputDir :: Flag (SymbolicPath Pkg (Dir Artifacts))
 568   , ghcOptStubDir :: Flag (SymbolicPath Pkg (Dir Artifacts))
 569   , --------------------
 570     -- Creating libraries
 571
 572     ghcOptDynLinkMode :: Flag GhcDynLinkMode
 573   , ghcOptStaticLib :: Flag Bool
 574   , ghcOptShared :: Flag Bool
 575   , ghcOptFPic :: Flag Bool
 576   , ghcOptDylibName :: Flag String
 577   , ghcOptRPaths :: NubListR FilePath
 578   , ---------------
 579     -- Misc flags
 580
 581     ghcOptVerbosity :: Flag Verbosity
 582   -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.
 583   , ghcOptExtraPath :: NubListR (SymbolicPath Pkg (Dir Build))
 584   -- ^ Put the extra folders in the PATH environment variable we invoke
 585   -- GHC with
 586   , ghcOptCabal :: Flag Bool
 587   -- ^ Let GHC know that it is Cabal that's calling it.
 588   -- Modifies some of the GHC error messages.
 589   }
 590   deriving (Show, Generic)
 591
 592 data GhcMode
 593   = -- | @ghc -c@
 594     GhcModeCompile
 595   | -- | @ghc@
 596     GhcModeLink
 597   | -- | @ghc --make@
 598     GhcModeMake
 599   | -- | @ghci@ \/ @ghc --interactive@
 600     GhcModeInteractive
 601   | -- | @ghc --abi-hash@
 602     --             | GhcModeDepAnalysis -- ^ @ghc -M@
 603     --             | GhcModeEvaluate    -- ^ @ghc -e@
 604     GhcModeAbiHash
 605   deriving (Show, Eq)
 606
 607 data GhcOptimisation
 608   = -- | @-O0@
 609     GhcNoOptimisation
 610   | -- | @-O@
 611     GhcNormalOptimisation
 612   | -- | @-O2@
 613     GhcMaximumOptimisation
 614   | -- | e.g. @-Odph@
 615     GhcSpecialOptimisation String
 616   deriving (Show, Eq)
 617
 618 data GhcDynLinkMode
 619   = -- | @-static@
 620     GhcStaticOnly
 621   | -- | @-dynamic@
 622     GhcDynamicOnly
 623   | -- | @-static -dynamic-too@
 624     GhcStaticAndDynamic
 625   deriving (Show, Eq)
 626
 627 data GhcProfAuto
 628   = -- | @-fprof-auto@
 629     GhcProfAutoAll
 630   | -- | @-fprof-auto-top@
 631     GhcProfAutoToplevel
 632   | -- | @-fprof-auto-exported@
 633     GhcProfAutoExported
 634   | -- | @-fprof-late
 635     GhcProfLate
 636   deriving (Show, Eq)
 637
 638 runGHC
 639   :: Verbosity
 640   -> ConfiguredProgram
 641   -> Compiler
 642   -> Platform
 643   -> Maybe (SymbolicPath CWD (Dir Pkg))
 644   -> GhcOptions
 645   -> IO ()
 646 runGHC verbosity ghcProg comp platform mbWorkDir opts = do
 647   runProgramInvocation verbosity
 648     =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts
 649
 650 ghcInvocation
 651   :: Verbosity
 652   -> ConfiguredProgram
 653   -> Compiler
 654   -> Platform
 655   -> Maybe (SymbolicPath CWD (Dir Pkg))
 656   -> GhcOptions
 657   -> IO ProgramInvocation
 658 ghcInvocation verbosity ghcProg comp platform mbWorkDir opts = do
 659   -- NOTE: GHC is the only program whose path we modify with more values than
 660   -- the standard @extra-prog-path@, namely the folders of the executables in
 661   -- the components, see @componentGhcOptions@.
 662   let envOverrides = programOverrideEnv ghcProg
 663   extraPath <-
 664     getExtraPathEnv verbosity envOverrides $
 665       map getSymbolicPath $
 666         fromNubListR $
 667           ghcOptExtraPath opts
 668   let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath}
 669   return $
 670     programInvocationCwd mbWorkDir ghcProg' $
 671       renderGhcOptions comp platform opts
 672
 673 -- TODO: use the -working-dir GHC flag instead of setting the process
 674 -- working directory, as this improves error messages.
 675
 676 renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String]
 677 renderGhcOptions comp _platform@(Platform _arch os) opts
 678   | compilerFlavor comp `notElem` [GHC, GHCJS] =
 679       error $
 680         "Distribution.Simple.Program.GHC.renderGhcOptions: "
 681           ++ "compiler flavor must be 'GHC' or 'GHCJS'!"
 682   | otherwise =
 683       concat
 684         [ case flagToMaybe (ghcOptMode opts) of
 685             Nothing -> []
 686             Just GhcModeCompile -> ["-c"]
 687             Just GhcModeLink -> []
 688             Just GhcModeMake -> ["--make"]
 689             Just GhcModeInteractive -> ["--interactive"]
 690             Just GhcModeAbiHash -> ["--abi-hash"]
 691         , --     Just GhcModeDepAnalysis -> ["-M"]
 692           --     Just GhcModeEvaluate    -> ["-e", expr]
 693
 694           ghcOptExtraDefault opts
 695         , ["-no-link" | flagBool ghcOptNoLink]
 696         , ["-flink-rts" | flagBool ghcOptLinkRts]
 697         , ---------------
 698           -- Misc flags
 699
 700           maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))
 701         , ["-fbuilding-cabal-package" | flagBool ghcOptCabal]
 702         , ----------------
 703           -- Compilation
 704
 705           case flagToMaybe (ghcOptOptimisation opts) of
 706             Nothing -> []
 707             Just GhcNoOptimisation -> ["-O0"]
 708             Just GhcNormalOptimisation -> ["-O"]
 709             Just GhcMaximumOptimisation -> ["-O2"]
 710             Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph
 711         , case flagToMaybe (ghcOptDebugInfo opts) of
 712             Nothing -> []
 713             Just NoDebugInfo -> []
 714             Just MinimalDebugInfo -> ["-g1"]
 715             Just NormalDebugInfo -> ["-g2"]
 716             Just MaximalDebugInfo -> ["-g3"]
 717         , ["-prof" | flagBool ghcOptProfilingMode]
 718         , case flagToMaybe (ghcOptProfilingAuto opts) of
 719             _
 720               | not (flagBool ghcOptProfilingMode) ->
 721                   []
 722             Nothing -> []
 723             Just GhcProfAutoAll
 724               | flagProfAuto implInfo -> ["-fprof-auto"]
 725               | otherwise -> ["-auto-all"] -- not the same, but close
 726             Just GhcProfLate
 727               | flagProfLate implInfo -> ["-fprof-late"]
 728               | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have.
 729             Just GhcProfAutoToplevel
 730               | flagProfAuto implInfo -> ["-fprof-auto-top"]
 731               | otherwise -> ["-auto-all"]
 732             Just GhcProfAutoExported
 733               | flagProfAuto implInfo -> ["-fprof-auto-exported"]
 734               | otherwise -> ["-auto"]
 735         , ["-split-sections" | flagBool ghcOptSplitSections]
 736         , case compilerCompatVersion GHC comp of
 737             -- the -split-objs flag was removed in GHC 9.8
 738             Just ver | ver >= mkVersion [9, 8] -> []
 739             _ -> ["-split-objs" | flagBool ghcOptSplitObjs]
 740         , case flagToMaybe (ghcOptHPCDir opts) of
 741             Nothing -> []
 742             Just hpcdir -> ["-fhpc", "-hpcdir", u hpcdir]
 743         , if parmakeSupported comp
 744             then case ghcOptNumJobs opts of
 745               NoFlag -> []
 746               Flag Serial -> []
 747               Flag (UseSem name) ->
 748                 if jsemSupported comp
 749                   then ["-jsem " ++ name]
 750                   else []
 751               Flag (NumJobs n) -> ["-j" ++ maybe "" show n]
 752             else []
 753         , --------------------
 754           -- Creating libraries
 755
 756           ["-staticlib" | flagBool ghcOptStaticLib]
 757         , ["-shared" | flagBool ghcOptShared]
 758         , case flagToMaybe (ghcOptDynLinkMode opts) of
 759             Nothing -> []
 760             Just GhcStaticOnly -> ["-static"]
 761             Just GhcDynamicOnly -> ["-dynamic"]
 762             Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]
 763         , ["-fPIC" | flagBool ghcOptFPic]
 764         , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName]
 765         , ------------------------
 766           -- Redirecting outputs
 767
 768           concat [["-osuf", suf] | suf <- flag ghcOptObjSuffix]
 769         , concat [["-hisuf", suf] | suf <- flag ghcOptHiSuffix]
 770         , concat [["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix]
 771         , concat [["-dynhisuf", suf] | suf <- flag ghcOptDynHiSuffix]
 772         , concat [["-outputdir", u dir] | dir <- flag ghcOptOutputDir]
 773         , concat [["-odir", u dir] | dir <- flag ghcOptObjDir]
 774         , concat [["-hidir", u dir] | dir <- flag ghcOptHiDir]
 775         , concat [["-hiedir", u dir] | dir <- flag ghcOptHieDir]
 776         , concat [["-stubdir", u dir] | dir <- flag ghcOptStubDir]
 777         , -----------------------
 778           -- Source search path
 779
 780           ["-i" | flagBool ghcOptSourcePathClear]
 781         , ["-i" ++ u dir | dir <- flags ghcOptSourcePath]
 782         , --------------------
 783
 784           --------------------
 785           -- CPP, C, and C++ stuff
 786
 787           ["-I" ++ u dir | dir <- flags ghcOptCppIncludePath]
 788         , ["-optP" ++ opt | opt <- ghcOptCppOptions opts]
 789         , concat
 790             [ ["-optP-include", "-optP" ++ u inc]
 791             | inc <- flags ghcOptCppIncludes
 792             ]
 793         , ["-optc" ++ opt | opt <- ghcOptCcOptions opts]
 794         , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc
 795           let cxxflag = case compilerCompatVersion GHC comp of
 796                 Just v | v >= mkVersion [8, 10] -> "-optcxx"
 797                 _ -> "-optc"
 798            in [cxxflag ++ opt | opt <- ghcOptCxxOptions opts]
 799         , ["-opta" ++ opt | opt <- ghcOptAsmOptions opts]
 800         , concat [["-pgmc", cc] | cc <- flag ghcOptCcProgram]
 801         , -----------------
 802           -- Linker stuff
 803
 804           ["-optl" ++ opt | opt <- ghcOptLinkOptions opts]
 805         , ["-l" ++ lib | lib <- ghcOptLinkLibs opts]
 806         , ["-L" ++ u dir | dir <- flags ghcOptLinkLibPath]
 807         , if isOSX
 808             then
 809               concat
 810                 [ ["-framework", fmwk]
 811                 | fmwk <- flags ghcOptLinkFrameworks
 812                 ]
 813             else []
 814         , if isOSX
 815             then
 816               concat
 817                 [ ["-framework-path", u path]
 818                 | path <- flags ghcOptLinkFrameworkDirs
 819                 ]
 820             else []
 821         , ["-no-hs-main" | flagBool ghcOptLinkNoHsMain]
 822         , ["-dynload deploy" | not (null (flags ghcOptRPaths))]
 823         , ["-optl-Wl,-rpath," ++ dir | dir <- flags ghcOptRPaths]
 824         , flags ghcOptLinkModDefFiles
 825         , -------------
 826           -- Packages
 827
 828           concat
 829             [ [ if
 830                     | unitIdSupported comp -> "-this-unit-id"
 831                     | packageKeySupported comp -> "-this-package-key"
 832                     | otherwise -> "-package-name"
 833               , this_arg
 834               ]
 835             | this_arg <- flag ghcOptThisUnitId
 836             ]
 837         , concat
 838             [ ["-this-component-id", prettyShow this_cid]
 839             | this_cid <- flag ghcOptThisComponentId
 840             ]
 841         , if null (ghcOptInstantiatedWith opts)
 842             then []
 843             else
 844               "-instantiated-with"
 845                 : intercalate
 846                   ","
 847                   ( map
 848                       ( \(n, m) ->
 849                           prettyShow n
 850                             ++ "="
 851                             ++ prettyShow m
 852                       )
 853                       (ghcOptInstantiatedWith opts)
 854                   )
 855                 : []
 856         , concat [["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode]
 857         , ["-hide-all-packages" | flagBool ghcOptHideAllPackages]
 858         , ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules]
 859         , ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages]
 860         , packageDbArgs implInfo (interpretPackageDBStack Nothing (ghcOptPackageDBs opts))
 861         , concat $
 862             let space "" = ""
 863                 space xs = ' ' : xs
 864              in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)]
 865                 | (ipkgid, rns) <- flags ghcOptPackages
 866                 ]
 867         , ----------------------------
 868           -- Language and extensions
 869
 870           if supportsHaskell2010 implInfo
 871             then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage]
 872             else []
 873         , [ ext'
 874           | ext <- flags ghcOptExtensions
 875           , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of
 876               Just (Just arg) -> [arg]
 877               Just Nothing -> []
 878               Nothing ->
 879                 error $
 880                   "Distribution.Simple.Program.GHC.renderGhcOptions: "
 881                     ++ prettyShow ext
 882                     ++ " not present in ghcOptExtensionMap."
 883           ]
 884         , ----------------
 885           -- GHCi
 886
 887           concat
 888             [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo
 889             ]
 890         , ---------------
 891           -- Inputs
 892
 893           -- Specify the input file(s) first, so that in ghci the `main-is` module is
 894           -- in scope instead of the first module defined in `other-modules`.
 895           map u $ flags ghcOptInputFiles
 896         , concat [["-x", "hs", u script] | script <- flags ghcOptInputScripts]
 897         , [prettyShow modu | modu <- flags ghcOptInputModules]
 898         , concat [["-o", u out] | out <- flag ghcOptOutputFile]
 899         , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile]
 900         , ---------------
 901           -- Extra
 902
 903           ghcOptExtra opts
 904         ]
 905   where
 906     -- See Note [Symbolic paths] in Distribution.Utils.Path
 907     u :: SymbolicPath Pkg to -> FilePath
 908     u = interpretSymbolicPathCWD
 909     implInfo = getImplInfo comp
 910     isOSX = os == OSX
 911     flag flg = flagToList (flg opts)
 912     flags flg = fromNubListR . flg $ opts
 913     flagBool flg = fromFlagOrDefault False (flg opts)
 914
 915 verbosityOpts :: Verbosity -> [String]
 916 verbosityOpts verbosity
 917   | verbosity >= deafening = ["-v"]
 918   | verbosity >= normal = []
 919   | otherwise = ["-w", "-v0"]
 920
 921 -- | GHC <7.6 uses '-package-conf' instead of '-package-db'.
 922 packageDbArgsConf :: PackageDBStackCWD -> [String]
 923 packageDbArgsConf dbstack = case dbstack of
 924   (GlobalPackageDB : UserPackageDB : dbs) -> concatMap specific dbs
 925   (GlobalPackageDB : dbs) ->
 926     ("-no-user-package-conf")
 927       : concatMap specific dbs
 928   _ -> ierror
 929   where
 930     specific (SpecificPackageDB db) = ["-package-conf", db]
 931     specific _ = ierror
 932     ierror =
 933       error $
 934         "internal error: unexpected package db stack: "
 935           ++ show dbstack
 936
 937 -- | GHC >= 7.6 uses the '-package-db' flag. See
 938 -- https://gitlab.haskell.org/ghc/ghc/-/issues/5977.
 939 packageDbArgsDb :: PackageDBStackCWD -> [String]
 940 -- special cases to make arguments prettier in common scenarios
 941 packageDbArgsDb dbstack = case dbstack of
 942   (GlobalPackageDB : UserPackageDB : dbs)
 943     | all isSpecific dbs -> concatMap single dbs
 944   (GlobalPackageDB : dbs)
 945     | all isSpecific dbs ->
 946         "-no-user-package-db"
 947           : concatMap single dbs
 948   dbs ->
 949     "-clear-package-db"
 950       : concatMap single dbs
 951   where
 952     single (SpecificPackageDB db) = ["-package-db", db]
 953     single GlobalPackageDB = ["-global-package-db"]
 954     single UserPackageDB = ["-user-package-db"]
 955     isSpecific (SpecificPackageDB _) = True
 956     isSpecific _ = False
 957
 958 packageDbArgs :: GhcImplInfo -> PackageDBStackCWD -> [String]
 959 packageDbArgs implInfo
 960   | flagPackageConf implInfo = packageDbArgsConf
 961   | otherwise = packageDbArgsDb
 962
 963 -- -----------------------------------------------------------------------------
 964 -- Boilerplate Monoid instance for GhcOptions
 965
 966 instance Monoid GhcOptions where
 967   mempty = gmempty
 968   mappend = (<>)
 969
 970 instance Semigroup GhcOptions where
 971   (<>) = gmappend