GhcBuild.hs

{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-
  There is a lot of code copied from GHC here, and some conditional
  compilation. Instead of fixing all warnings and making it much more
  difficult to compare the code to the original, just ignore unused
  binds and imports.
-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE PatternGuards       #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-
  build package with the GHC API
-}

module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where

import qualified Control.Exception as Ex
import           Control.Monad      (when)
import           Data.IORef
import           System.Process     (rawSystem)
import           System.Environment (getEnvironment)

import           CmdLineParser
import           Data.Char          (toLower)
import           Data.List          (isPrefixOf, isSuffixOf, partition)
import           Data.Maybe         (fromMaybe)
import           DriverPhases       (Phase (..), anyHsc, isHaskellSrcFilename,
                                     isSourceFilename, startPhase)
import           DriverPipeline     (compileFile, link, linkBinary, oneShot)
import           DynFlags           (DynFlags, compilerInfo)
import qualified DynFlags
import qualified DynFlags           as DF
import qualified GHC
import           GHC.Paths          (libdir)
import           HscTypes           (HscEnv (..), emptyHomePackageTable)
import qualified Module
import           MonadUtils         (liftIO)
import           Panic              (throwGhcException, panic)
import           SrcLoc             (Located, mkGeneralLocated)
import qualified StaticFlags
import           StaticFlags        (v_Ld_inputs)
import           System.FilePath    (normalise, (</>))
import           Util               (consIORef, looksLikeModuleName)

{-
  This contains a huge hack:
  GHC only accepts setting static flags once per process, however it has no way to
  get the remaining options from the command line, without setting the static flags.
  This code overwrites the IORef to disable the check. This will likely cause
  problems if the flags are modified, but fortunately that's relatively uncommon.
-}
getBuildFlags :: IO [Located String]
getBuildFlags = do
  argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper
  argv0' <- prependHsenvArgv argv0
  let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0'
      mbMinusB | null minusB_args = Nothing
               | otherwise = Just (drop 2 (last minusB_args))
  let argv1' = map (mkGeneralLocated "on the commandline") argv1
  writeIORef StaticFlags.v_opt_C_ready False -- the huge hack
  (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
  return argv2

prependHsenvArgv :: [String] -> IO [String]
prependHsenvArgv argv = do
  env <- getEnvironment
  return $ case (lookup "HSENV" env) of
             Nothing -> argv
             _       -> hsenvArgv ++ argv
                 where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env)

-- construct a command line for loading the right packages
getPackageArgs :: Maybe String -> [Located String] -> IO [String]
getPackageArgs buildDir argv2 = do
  (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
  GHC.runGhc (Just libdir) $ do
    dflags0 <- GHC.getSessionDynFlags
    (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
    let pkgFlags = map convertPkgFlag (GHC.packageFlags dflags1)
        hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"]
                | otherwise                           = []
        ownPkg = "-package-id" ++ Module.packageIdString (DF.thisPackage dflags1) ++ "-inplace"
    return (extra dflags1 ++ hideAll ++ pkgFlags ++ [ownPkg])
  where
    convertPkgFlag (DF.ExposePackage p)   = "-package" ++ p
    convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p
    convertPkgFlag (DF.HidePackage p)     = "-hide-package" ++ p
    convertPkgFlag (DF.IgnorePackage p)   = "-ignore-package" ++ p
    convertPkgFlag (DF.TrustPackage p)    = "-trust" ++ p
    convertPkgFlag (DF.DistrustPackage p) ="-distrust" ++ p
#if __GLASGOW_HASKELL__ >= 705
    extra df = inplaceConf ++ extra'
      where
         extra' = concatMap convertExtra (extraConfs df)
         -- old cabal-install sometimes misses the .inplace db, fix it here
         inplaceConf
           | any (".inplace" `isSuffixOf`) extra' = []
           | otherwise = ["-package-db" ++ fromMaybe "dist" buildDir
                           ++ "/package.conf.inplace"]
    extraConfs df = GHC.extraPkgConfs df []
    convertExtra DF.GlobalPkgConf      = [ ]
    convertExtra DF.UserPkgConf        = [ ]
    convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ]
#else
    extra df  = inplaceConf ++ extra'
      where
        extra' = map ("-package-conf"++) (GHC.extraPkgConfs df)
         -- old cabal-install sometimes misses the .inplace db, fix it here
        inplaceConf
          | any (".inplace" `isSuffixOf`) extra' = []
          | otherwise = ["-package-conf" ++ fromMaybe "dist" buildDir
                           ++ "/package.conf.inplace"]
#endif

#if __GLASGOW_HASKELL__ >= 707
    gopt = DF.gopt
#else
    gopt = DF.dopt
#endif


buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool
buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do
  putStrLn ("exception building package: " ++ show (e :: Ex.SomeException))
  return False

buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool
buildPackage' argv2 ld ar = do
  (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
  GHC.runGhc (Just libdir) $ do
    dflags0 <- GHC.getSessionDynFlags
    (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
    let dflags2 = dflags1 { GHC.ghcMode   = GHC.CompManager
                          , GHC.hscTarget = GHC.hscTarget dflags1
                          , GHC.ghcLink   = GHC.LinkBinary
                          , GHC.verbosity = 1
                          }
    (dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3
    GHC.setSessionDynFlags dflags3
    let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args
        (srcs, objs)         = partition_args normal_fileish_paths [] []
        (hs_srcs, non_hs_srcs) = partition haskellish srcs
        haskellish (f,Nothing) =
          looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
        haskellish (_,Just phase) =
#if MIN_VERSION_ghc(7,4,0)
          phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
#else
          phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
#endif
    hsc_env <- GHC.getSession
--    if (null hs_srcs)
--       then liftIO (oneShot hsc_env StopLn srcs)
--       else do
#if MIN_VERSION_ghc(7,2,0)
    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
#else
    o_files <- mapM (\x -> compileFile hsc_env StopLn x)
#endif
                 non_hs_srcs
    liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
    GHC.setTargets targets
    ok_flag <- GHC.load GHC.LoadAllTargets
    if GHC.failed ok_flag
      then return False
      else liftIO (linkPkg ld ar) >> return True

linkPkg :: FilePath -> FilePath -> IO ()
linkPkg ld ar = do
  arargs <- fmap read $ readFile "yesod-devel/arargs.txt"
  rawSystem ar arargs
  ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt"
  rawSystem ld ldargs
  return ()

--------------------------------------------------------------------------------------------
-- stuff below copied from ghc main.hs
--------------------------------------------------------------------------------------------

partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
  | "none" <- suff      = partition_args args srcs objs
  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
        where phase = startPhase suff
              (slurp,rest) = break (== "-x") args
              these_srcs = zip slurp (repeat (Just phase))
partition_args (arg:args) srcs objs
  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
  | otherwise               = partition_args args srcs (arg:objs)

    {-
      We split out the object files (.o, .dll) and add them
      to v_Ld_inputs for use by the linker.

      The following things should be considered compilation manager inputs:

       - haskell source files (strings ending in .hs, .lhs or other
         haskellish extension),

       - module names (not forgetting hierarchical module names),

       - and finally we consider everything not containing a '.' to be
         a comp manager input, as shorthand for a .hs or .lhs filename.

      Everything else is considered to be a linker object, and passed
      straight through to the linker.
    -}
looks_like_an_input :: String -> Bool
looks_like_an_input m =  isSourceFilename m
                      || looksLikeModuleName m
                      || '.' `notElem` m



-- Parsing the mode flag

parseModeFlags :: [Located String]
               -> IO (Mode,
                      [Located String],
                      [Located String])
parseModeFlags args = do
  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
          runCmdLine (processArgs mode_flags args)
                     (Nothing, [], [])
      mode = case mModeFlag of
             Nothing     -> doMakeMode
             Just (m, _) -> m
      errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
  when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
  return (mode, flags' ++ leftover, warns)

type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
  -- so we collect the new ones and return them.

mode_flags :: [Flag ModeM]
mode_flags =
  [  ------- help / version ----------------------------------------------
    Flag "?"                     (PassFlag (setMode showGhcUsageMode))
  , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
  , Flag "V"                     (PassFlag (setMode showVersionMode))
  , Flag "-version"              (PassFlag (setMode showVersionMode))
  , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
  , Flag "-info"                 (PassFlag (setMode showInfoMode))
  , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
  , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
  ] ++
  [ Flag k'                      (PassFlag (setMode (printSetting k)))
  | k <- ["Project version",
          "Booter version",
          "Stage",
          "Build platform",
          "Host platform",
          "Target platform",
          "Have interpreter",
          "Object splitting supported",
          "Have native code generator",
          "Support SMP",
          "Unregisterised",
          "Tables next to code",
          "RTS ways",
          "Leading underscore",
          "Debug on",
          "LibDir",
          "Global Package DB",
          "C compiler flags",
          "Gcc Linker flags",
          "Ld Linker flags"],
    let k' = "-print-" ++ map (replaceSpace . toLower) k
        replaceSpace ' ' = '-'
        replaceSpace c   = c
  ] ++
      ------- interfaces ----------------------------------------------------
  [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
                                               "--show-iface"))

      ------- primary modes ------------------------------------------------
  , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
                                            addFlag "-no-link" f))
  , Flag "M"            (PassFlag (setMode doMkDependHSMode))
  , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
  , Flag "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
                                            addFlag "-fvia-C" f))
  , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
  , Flag "-make"        (PassFlag (setMode doMakeMode))
  , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
  , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
  , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
  ]

setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
    (mModeFlag, errs, flags') <- getCmdLineState
    let (modeFlag', errs') =
            case mModeFlag of
            Nothing -> ((newMode, newFlag), errs)
            Just (oldMode, oldFlag) ->
                case (oldMode, newMode) of
                    -- -c/--make are allowed together, and mean --make -no-link
                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
                      || isStopLnMode newMode && isDoMakeMode oldMode ->
                      ((doMakeMode, "--make"), [])

                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    _ | isShowGhcUsageMode oldMode &&
                        isDoInteractiveMode newMode ->
                            ((showGhciUsageMode, oldFlag), [])
                      | isShowGhcUsageMode newMode &&
                        isDoInteractiveMode oldMode ->
                            ((showGhciUsageMode, newFlag), [])
                    -- Otherwise, --help/--version/--numeric-version always win
                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
                      | isDominantFlag newMode -> ((newMode, newFlag), [])
                    -- We need to accumulate eval flags like "-e foo -e bar"
                    (Right (Right (DoEval esOld)),
                     Right (Right (DoEval [eNew]))) ->
                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),
                         errs)
                    -- Saying e.g. --interactive --interactive is OK
                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
                    -- Otherwise, complain
                    _ -> let err = flagMismatchErr oldFlag newFlag
                         in ((oldMode, oldFlag), err : errs)
    putCmdLineState (Just modeFlag', errs', flags')
  where isDominantFlag f = isShowGhcUsageMode   f ||
                           isShowGhciUsageMode  f ||
                           isShowVersionMode    f ||
                           isShowNumVersionMode f

flagMismatchErr :: String -> String -> String
flagMismatchErr oldFlag newFlag
    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"

addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
  (m, e, flags') <- getCmdLineState
  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
    where loc = "addFlag by " ++ flag ++ " on the commandline"

type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode

data PreStartupMode
  = ShowVersion             -- ghc -V/--version
  | ShowNumVersion          -- ghc --numeric-version
  | ShowSupportedExtensions -- ghc --supported-extensions
  | Print String            -- ghc --print-foo

showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
showVersionMode             = mkPreStartupMode ShowVersion
showNumVersionMode          = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions

mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = Left

isShowVersionMode :: Mode -> Bool
isShowVersionMode (Left ShowVersion) = True
isShowVersionMode _ = False

isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode (Left ShowNumVersion) = True
isShowNumVersionMode _ = False

data PreLoadMode
  = ShowGhcUsage                           -- ghc -?
  | ShowGhciUsage                          -- ghci -?
  | ShowInfo                               -- ghc --info
  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo

showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
showGhcUsageMode = mkPreLoadMode ShowGhcUsage
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
showInfoMode = mkPreLoadMode ShowInfo

printSetting :: String -> Mode
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
#if MIN_VERSION_ghc(7,2,0)
                   $ lookup k (compilerInfo dflags)
#else
                   $ fmap convertPrintable (lookup k compilerInfo)
              where
                convertPrintable (DynFlags.String s) = s
                convertPrintable (DynFlags.FromDynFlags f) = f dflags
#endif

mkPreLoadMode :: PreLoadMode -> Mode
mkPreLoadMode = Right . Left

isShowGhcUsageMode :: Mode -> Bool
isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
isShowGhcUsageMode _ = False

isShowGhciUsageMode :: Mode -> Bool
isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
isShowGhciUsageMode _ = False

data PostLoadMode
  = ShowInterface FilePath  -- ghc --show-iface
  | DoMkDependHS            -- ghc -M
  | StopBefore Phase        -- ghc -E | -C | -S
                            -- StopBefore StopLn is the default
  | DoMake                  -- ghc --make
  | DoInteractive           -- ghc --interactive
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
  | DoAbiHash               -- ghc --abi-hash

doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
doMkDependHSMode = mkPostLoadMode DoMkDependHS
doMakeMode = mkPostLoadMode DoMake
doInteractiveMode = mkPostLoadMode DoInteractive
doAbiHashMode = mkPostLoadMode DoAbiHash


showInterfaceMode :: FilePath -> Mode
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)

stopBeforeMode :: Phase -> Mode
stopBeforeMode phase = mkPostLoadMode (StopBefore phase)

doEvalMode :: String -> Mode
doEvalMode str = mkPostLoadMode (DoEval [str])

mkPostLoadMode :: PostLoadMode -> Mode
mkPostLoadMode = Right . Right

isDoInteractiveMode :: Mode -> Bool
isDoInteractiveMode (Right (Right DoInteractive)) = True
isDoInteractiveMode _ = False

isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopLn))) = True
isStopLnMode _ = False

isDoMakeMode :: Mode -> Bool
isDoMakeMode (Right (Right DoMake)) = True
isDoMakeMode _ = False

#ifdef GHCI
isInteractiveMode :: PostLoadMode -> Bool
isInteractiveMode DoInteractive = True
isInteractiveMode _             = False
#endif

-- isInterpretiveMode: byte-code compiler involved
isInterpretiveMode :: PostLoadMode -> Bool
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _)    = True
isInterpretiveMode _             = False

needsInputsMode :: PostLoadMode -> Bool
needsInputsMode DoMkDependHS    = True
needsInputsMode (StopBefore _)  = True
needsInputsMode DoMake          = True
needsInputsMode _               = False

-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
isLinkMode :: PostLoadMode -> Bool
isLinkMode (StopBefore StopLn) = True
isLinkMode DoMake              = True
isLinkMode DoInteractive       = True
isLinkMode (DoEval _)          = True
isLinkMode _                   = False

isCompManagerMode :: PostLoadMode -> Bool
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _)    = True
isCompManagerMode _             = False