content: module Distribution.Simple.Program.GHC (
      GhcOptions(..),
      GhcMode(..),
      GhcOptimisation(..),
      GhcDynLinkMode(..),
  
      ghcInvocation,
      renderGhcOptions,
  
      runGHC,
  
    ) where
  
  import Distribution.Package
  import Distribution.ModuleName
  import Distribution.Simple.Compiler hiding (Flag)
  import Distribution.Simple.Setup    (Flag(..), flagToMaybe, fromFlagOrDefault, flagToList)
  --import Distribution.Simple.LocalBuildInfo
  import Distribution.Simple.Program.Types
  import Distribution.Simple.Program.Run
  import Distribution.Text
  import Distribution.Verbosity
  import Distribution.Version
  import Language.Haskell.Extension ( Language(..), Extension(..) )
  
  import Data.Monoid
  
  
  -- | A structured set of GHC options/flags
  --
  data GhcOptions = GhcOptions {
  
    -- | The major mode for the ghc invocation.
    ghcOptMode          :: Flag GhcMode,
  
    -- | Any extra options to pass directly to ghc. These go at the end and hence
    -- override other stuff.
    ghcOptExtra         :: [String],
  
    -- | Extra default flags to pass directly to ghc. These go at the beginning
    -- and so can be overridden by other stuff.
    ghcOptExtraDefault  :: [String],
  
    -----------------------
    -- Inputs and outputs
  
    -- | The main input files; could be .hs, .hi, .c, .o, depending on mode.
    ghcOptInputFiles    :: [FilePath],
  
    -- | The names of input Haskell modules, mainly for @--make@ mode.
    ghcOptInputModules  :: [ModuleName],
  
    -- | Location for output file; the @ghc -o@ flag.
    ghcOptOutputFile    :: Flag FilePath,
  
    -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode;
    -- the @ghc -dyno@ flag.
    ghcOptOutputDynFile :: Flag FilePath,
  
    -- | Start with an empty search path for Haskell source files;
    -- the @ghc -i@ flag (@-i@ on it's own with no path argument).
    ghcOptSourcePathClear :: Flag Bool,
  
    -- | Search path for Haskell source files; the @ghc -i@ flag.
    ghcOptSourcePath    :: [FilePath],
  
    -------------
    -- Packages
  
    -- | The package name the modules will belong to; the @ghc -package-name@ flag
    ghcOptPackageName   :: Flag PackageId,
  
    -- | GHC package databases to use, the @ghc -package-conf@ flag
    ghcOptPackageDBs    :: PackageDBStack,
  
    -- | The GHC packages to use. For compatability with old and new ghc, this
    -- requires both the short and long form of the package id;
    -- the @ghc -package@ or @ghc -package-id@ flags.
    ghcOptPackages      :: [(InstalledPackageId, PackageId)],
  
    -- | Start with a clean package set; the @ghc -hide-all-packages@ flag
    ghcOptHideAllPackages :: Flag Bool,
  
    -- | Don't automatically link in Haskell98 etc; the @ghc -no-auto-link-packages@ flag.
    ghcOptNoAutoLinkPackages :: Flag Bool,
  
    -----------------
    -- Linker stuff
  
    -- | Names of libraries to link in; the @ghc -l@ flag.
    ghcOptLinkLibs      :: [FilePath],
  
    -- | Search path for libraries to link in; the @ghc -L@ flag.
    ghcOptLinkLibPath  :: [FilePath],
  
    -- | Options to pass through to the linker; the @ghc -optl@ flag.
    ghcOptLinkOptions   :: [String],
  
    -- | OSX only: frameworks to link in; the @ghc -framework@ flag.
    ghcOptLinkFrameworks :: [String],
  
    -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.
    ghcOptNoLink :: Flag Bool,
  
    -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ flag.
    ghcOptLinkNoHsMain :: Flag Bool,
  
    --------------------
    -- C and CPP stuff
  
    -- | Options to pass through to the C compiler; the @ghc -optc@ flag.
    ghcOptCcOptions     :: [String],
  
    -- | Options to pass through to CPP; the @ghc -optP@ flag.
    ghcOptCppOptions    :: [String],
  
    -- | Search path for CPP includes like header files; the @ghc -I@ flag.
    ghcOptCppIncludePath :: [FilePath],
  
    -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag.
    ghcOptCppIncludes    :: [FilePath],
  
    -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag.
    ghcOptFfiIncludes    :: [FilePath],
  
    ----------------------------
    -- Language and extensions
  
    -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.
    ghcOptLanguage      :: Flag Language,
  
    -- | The language extensions; the @ghc -X@ flag.
    ghcOptExtensions    :: [Extension],
  
    -- | A GHC version-dependent mapping of extensions to flags. This must be
    -- set to be able to make use of the 'ghcOptExtensions'.
    ghcOptExtensionMap    :: [(Extension, String)],
  
    ----------------
    -- Compilation
  
    -- | What optimisation level to use; the @ghc -O@ flag.
    ghcOptOptimisation  :: Flag GhcOptimisation,
  
    -- | Compile in profiling mode; the @ghc -prof@ flag.
    ghcOptProfilingMode :: Flag Bool,
  
    -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.
    ghcOptSplitObjs     :: Flag Bool,
  
    ----------------
    -- GHCi
  
    -- | Extra GHCi startup scripts; the @-ghci-script@ flag
    ghcOptGHCiScripts    :: [FilePath],
  
    ------------------------
    -- Redirecting outputs
  
    ghcOptHiSuffix      :: Flag String,
    ghcOptObjSuffix     :: Flag String,
    ghcOptDynHiSuffix   :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode
    ghcOptDynObjSuffix  :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode
    ghcOptHiDir         :: Flag FilePath,
    ghcOptObjDir        :: Flag FilePath,
    ghcOptOutputDir     :: Flag FilePath,
    ghcOptStubDir       :: Flag FilePath,
  
    --------------------
    -- Dynamic linking
  
    ghcOptDynLinkMode   :: Flag GhcDynLinkMode,
    ghcOptShared        :: Flag Bool,
    ghcOptFPic          :: Flag Bool,
    ghcOptDylibName     :: Flag String,
  
    ---------------
    -- Misc flags
  
    -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.
    ghcOptVerbosity     :: Flag Verbosity,
  
    -- | Let GHC know that it is Cabal that's calling it.
    -- Modifies some of the GHC error messages.
    ghcOptCabal         :: Flag Bool
  
  } deriving Show
  
  
  data GhcMode = GhcModeCompile     -- ^ @ghc -c@
               | GhcModeLink        -- ^ @ghc@
               | GhcModeMake        -- ^ @ghc --make@
               | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@
               | GhcModeAbiHash     -- ^ @ghc --abi-hash@
  --             | GhcModeDepAnalysis -- ^ @ghc -M@
  --             | GhcModeEvaluate    -- ^ @ghc -e@
   deriving (Show, Eq)
  
  data GhcOptimisation = GhcNoOptimisation             -- ^ @-O0@
                       | GhcNormalOptimisation         -- ^ @-O@
                       | GhcMaximumOptimisation        -- ^ @-O2@
                       | GhcSpecialOptimisation String -- ^ e.g. @-Odph@
   deriving (Show, Eq)
  
  data GhcDynLinkMode = GhcStaticOnly       -- ^ @-static@
                      | GhcDynamicOnly      -- ^ @-dynamic@
                      | GhcStaticAndDynamic -- ^ @-static -dynamic-too@
   deriving (Show, Eq)
  
  
  runGHC :: Verbosity -> ConfiguredProgram -> GhcOptions -> IO ()
  runGHC verbosity ghcProg opts = do
    runProgramInvocation verbosity (ghcInvocation ghcProg opts)
  
  
  ghcInvocation :: ConfiguredProgram -> GhcOptions -> ProgramInvocation
  ghcInvocation ConfiguredProgram { programVersion = Nothing } _ =
      error "ghcInvocation: the programVersion must not be Nothing"
  ghcInvocation prog@ConfiguredProgram { programVersion = Just ver } opts =
      programInvocation prog (renderGhcOptions ver opts)
  
  
  renderGhcOptions :: Version -> GhcOptions -> [String]
  renderGhcOptions version@(Version ver _) opts =
    concat
    [ case flagToMaybe (ghcOptMode opts) of
         Nothing                 -> []
         Just GhcModeCompile     -> ["-c"]
         Just GhcModeLink        -> []
         Just GhcModeMake        -> ["--make"]
         Just GhcModeInteractive -> ["--interactive"]
         Just GhcModeAbiHash     -> ["--abi-hash"]
  --     Just GhcModeDepAnalysis -> ["-M"]
  --     Just GhcModeEvaluate    -> ["-e", expr]
  
    , flags ghcOptExtraDefault
  
    , [ "-no-link" | flagBool ghcOptNoLink ]
  
    ---------------
    -- Misc flags
  
    , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))
  
    , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal, ver >= [6,11] ]
  
    ----------------
    -- Compilation
  
    , case flagToMaybe (ghcOptOptimisation opts) of
        Nothing                         -> []
        Just GhcNoOptimisation          -> ["-O0"]
        Just GhcNormalOptimisation      -> ["-O"]
        Just GhcMaximumOptimisation     -> ["-O2"]
        Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph
  
    , [ "-prof" | flagBool ghcOptProfilingMode ]
  
    , [ "-split-objs" | flagBool ghcOptSplitObjs ]
  
    --------------------
    -- Dynamic linking
  
    , [ "-shared"  | flagBool ghcOptShared  ]
    , case flagToMaybe (ghcOptDynLinkMode opts) of
        Nothing                  -> []
        Just GhcStaticOnly       -> ["-static"]
        Just GhcDynamicOnly      -> ["-dynamic"]
        Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]
    , [ "-fPIC"    | flagBool ghcOptFPic ]
  
    , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]
  
    ------------------------
    -- Redirecting outputs
  
    , concat [ ["-osuf",    suf] | suf <- flag ghcOptObjSuffix ]
    , concat [ ["-hisuf",   suf] | suf <- flag ghcOptHiSuffix  ]
    , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]
    , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix  ]
    , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir, ver >= [6,10] ]
    , concat [ ["-odir",    dir] | dir <- flag ghcOptObjDir ]
    , concat [ ["-hidir",   dir] | dir <- flag ghcOptHiDir  ]
    , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ]
  
    -----------------------
    -- Source search path
  
    , [ "-i"        | flagBool ghcOptSourcePathClear ]
    , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ]
  
    --------------------
    -- C and CPP stuff
  
    , [ "-I"    ++ dir | dir <- flags ghcOptCppIncludePath ]
    , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ]
    , concat [ [ "-optP-include", "-optP" ++ inc] | inc <- flags ghcOptCppIncludes ]
    , [ "-#include \"" ++ inc ++ "\"" | inc <- flags ghcOptFfiIncludes, ver < [6,11] ]
    , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ]
  
    -----------------
    -- Linker stuff
  
    , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ]
    , ["-l" ++ lib     | lib <- flags ghcOptLinkLibs ]
    , ["-L" ++ dir     | dir <- flags ghcOptLinkLibPath ]
    , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]
    , [ "-no-hs-main"  | flagBool ghcOptLinkNoHsMain ]
  
    -------------
    -- Packages
  
    , concat [ ["-package-name", display pkgid] | pkgid <- flag ghcOptPackageName ]
  
    , [ "-hide-all-packages"     | flagBool ghcOptHideAllPackages ]
    , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]
  
    , packageDbArgs version (flags ghcOptPackageDBs)
  
    , concat $ if ver >= [6,11]
        then [ ["-package-id", display ipkgid] | (ipkgid,_) <- flags ghcOptPackages ]
        else [ ["-package",    display  pkgid] | (_,pkgid)  <- flags ghcOptPackages ]
  
    ----------------------------
    -- Language and extensions
  
    , if ver >= [7]
      then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ]
      else []
  
    , [ case lookup ext (ghcOptExtensionMap opts) of
          Just arg -> arg
          Nothing  -> error $ "renderGhcOptions: " ++ display ext
                            ++ " not present in ghcOptExtensionMap."
      | ext <- ghcOptExtensions opts ]
  
    ----------------
    -- GHCi
  
    , concat [ [ "-ghci-script", script ] | script <- flags  ghcOptGHCiScripts
                                          , ver >= [7,2] ]
  
    ---------------
    -- Inputs
  
    , [ display modu | modu <- flags ghcOptInputModules ]
    , ghcOptInputFiles opts
  
    , concat [ [ "-o",    out] | out <- flag ghcOptOutputFile ]
    , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]
  
    ---------------
    -- Extra
  
    , ghcOptExtra opts
  
    ]
  
  
    where
      flag     flg = flagToList (flg opts)
      flags    flg = flg opts
      flagBool flg = fromFlagOrDefault False (flg opts)
  
  
  verbosityOpts :: Verbosity -> [String]
  verbosityOpts verbosity
    | verbosity >= deafening = ["-v"]
    | verbosity >= normal    = []
    | otherwise              = ["-w", "-v0"]
  
  
  packageDbArgs :: Version -> PackageDBStack -> [String]
  packageDbArgs (Version ver _) dbstack = case dbstack of
    (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
    (GlobalPackageDB:dbs)               -> ("-no-user-" ++ packageDbFlag)
                                         : concatMap specific dbs
    _ -> ierror
    where
      specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ]
      specific _ = ierror
      ierror     = error $ "internal error: unexpected package db stack: "
                        ++ show dbstack
  
      packageDbFlag
        | ver < [7,5]
        = "package-conf"
        | otherwise
        = "package-db"
  
  
  -- -----------------------------------------------------------------------------
  -- Boilerplate Monoid instance for GhcOptions
  
  instance Monoid GhcOptions where
    mempty = GhcOptions {
      ghcOptMode               = mempty,
      ghcOptExtra              = mempty,
      ghcOptExtraDefault       = mempty,
      ghcOptInputFiles         = mempty,
      ghcOptInputModules       = mempty,
      ghcOptOutputFile         = mempty,
      ghcOptOutputDynFile      = mempty,
      ghcOptSourcePathClear    = mempty,
      ghcOptSourcePath         = mempty,
      ghcOptPackageName        = mempty,
      ghcOptPackageDBs         = mempty,
      ghcOptPackages           = mempty,
      ghcOptHideAllPackages    = mempty,
      ghcOptNoAutoLinkPackages = mempty,
      ghcOptLinkLibs           = mempty,
      ghcOptLinkLibPath        = mempty,
      ghcOptLinkOptions        = mempty,
      ghcOptLinkFrameworks     = mempty,
      ghcOptNoLink             = mempty,
      ghcOptLinkNoHsMain       = mempty,
      ghcOptCcOptions          = mempty,
      ghcOptCppOptions         = mempty,
      ghcOptCppIncludePath     = mempty,
      ghcOptCppIncludes        = mempty,
      ghcOptFfiIncludes        = mempty,
      ghcOptLanguage           = mempty,
      ghcOptExtensions         = mempty,
      ghcOptExtensionMap       = mempty,
      ghcOptOptimisation       = mempty,
      ghcOptProfilingMode      = mempty,
      ghcOptSplitObjs          = mempty,
      ghcOptGHCiScripts        = mempty,
      ghcOptHiSuffix           = mempty,
      ghcOptObjSuffix          = mempty,
      ghcOptDynHiSuffix        = mempty,
      ghcOptDynObjSuffix       = mempty,
      ghcOptHiDir              = mempty,
      ghcOptObjDir             = mempty,
      ghcOptOutputDir          = mempty,
      ghcOptStubDir            = mempty,
      ghcOptDynLinkMode        = mempty,
      ghcOptShared             = mempty,
      ghcOptFPic               = mempty,
      ghcOptDylibName          = mempty,
      ghcOptVerbosity          = mempty,
      ghcOptCabal              = mempty
    }
    mappend a b = GhcOptions {
      ghcOptMode               = combine ghcOptMode,
      ghcOptExtra              = combine ghcOptExtra,
      ghcOptExtraDefault       = combine ghcOptExtraDefault,
      ghcOptInputFiles         = combine ghcOptInputFiles,
      ghcOptInputModules       = combine ghcOptInputModules,
      ghcOptOutputFile         = combine ghcOptOutputFile,
      ghcOptOutputDynFile      = combine ghcOptOutputDynFile,
      ghcOptSourcePathClear    = combine ghcOptSourcePathClear,
      ghcOptSourcePath         = combine ghcOptSourcePath,
      ghcOptPackageName        = combine ghcOptPackageName,
      ghcOptPackageDBs         = combine ghcOptPackageDBs,
      ghcOptPackages           = combine ghcOptPackages,
      ghcOptHideAllPackages    = combine ghcOptHideAllPackages,
      ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,
      ghcOptLinkLibs           = combine ghcOptLinkLibs,
      ghcOptLinkLibPath        = combine ghcOptLinkLibPath,
      ghcOptLinkOptions        = combine ghcOptLinkOptions,
      ghcOptLinkFrameworks     = combine ghcOptLinkFrameworks,
      ghcOptNoLink             = combine ghcOptNoLink,
      ghcOptLinkNoHsMain       = combine ghcOptLinkNoHsMain,
      ghcOptCcOptions          = combine ghcOptCcOptions,
      ghcOptCppOptions         = combine ghcOptCppOptions,
      ghcOptCppIncludePath     = combine ghcOptCppIncludePath,
      ghcOptCppIncludes        = combine ghcOptCppIncludes,
      ghcOptFfiIncludes        = combine ghcOptFfiIncludes,
      ghcOptLanguage           = combine ghcOptLanguage,
      ghcOptExtensions         = combine ghcOptExtensions,
      ghcOptExtensionMap       = combine ghcOptExtensionMap,
      ghcOptOptimisation       = combine ghcOptOptimisation,
      ghcOptProfilingMode      = combine ghcOptProfilingMode,
      ghcOptSplitObjs          = combine ghcOptSplitObjs,
      ghcOptGHCiScripts        = combine ghcOptGHCiScripts,
      ghcOptHiSuffix           = combine ghcOptHiSuffix,
      ghcOptObjSuffix          = combine ghcOptObjSuffix,
      ghcOptDynHiSuffix        = combine ghcOptDynHiSuffix,
      ghcOptDynObjSuffix       = combine ghcOptDynObjSuffix,
      ghcOptHiDir              = combine ghcOptHiDir,
      ghcOptObjDir             = combine ghcOptObjDir,
      ghcOptOutputDir          = combine ghcOptOutputDir,
      ghcOptStubDir            = combine ghcOptStubDir,
      ghcOptDynLinkMode        = combine ghcOptDynLinkMode,
      ghcOptShared             = combine ghcOptShared,
      ghcOptFPic               = combine ghcOptFPic,
      ghcOptDylibName          = combine ghcOptDylibName,
      ghcOptVerbosity          = combine ghcOptVerbosity,
      ghcOptCabal              = combine ghcOptCabal
    }
      where
        combine field = field a `mappend` field b
  