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

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