{-# LANGUAGE CPP #-}
module GhcUtil (withGhc) where
import GHC.Paths (libdir)
#if __GLASGOW_HASKELL__ < 707
import Control.Exception
import GHC hiding (flags)
import DynFlags (dopt_set)
#else
import GHC
import DynFlags (gopt_set)
#endif
import Panic (throwGhcException)
import MonadUtils (liftIO)
import System.Exit (exitFailure)
#if __GLASGOW_HASKELL__ < 702
import StaticFlags (v_opt_C_ready)
import Data.IORef (writeIORef)
#elif __GLASGOW_HASKELL__ < 707
import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals)
#elif __GLASGOW_HASKELL__ < 801
import StaticFlags (discardStaticFlags)
#endif
bracketStaticFlags :: IO a -> IO a
#if __GLASGOW_HASKELL__ < 702
bracketStaticFlags action = action `finally` writeIORef v_opt_C_ready False
#elif __GLASGOW_HASKELL__ < 707
bracketStaticFlags action = bracket saveStaticFlagGlobals restoreStaticFlagGlobals (const action)
#else
bracketStaticFlags action = action
#endif
handleSrcErrors :: Ghc a -> Ghc a
handleSrcErrors action' = flip handleSourceError action' $ \err -> do
#if __GLASGOW_HASKELL__ < 702
printExceptionAndWarnings err
#else
printException err
#endif
liftIO exitFailure
withGhc :: [String] -> ([String] -> Ghc a) -> IO a
withGhc flags action = bracketStaticFlags $ do
flags_ <- handleStaticFlags flags
runGhc (Just libdir) $ do
handleDynamicFlags flags_ >>= handleSrcErrors . action
handleStaticFlags :: [String] -> IO [Located String]
#if __GLASGOW_HASKELL__ < 707
handleStaticFlags flags = fst `fmap` parseStaticFlags (map noLoc flags)
#elif __GLASGOW_HASKELL__ < 801
handleStaticFlags flags = return $ map noLoc $ discardStaticFlags flags
#else
handleStaticFlags flags = return $ map noLoc $ flags
#endif
handleDynamicFlags :: GhcMonad m => [Located String] -> m [String]
handleDynamicFlags flags = do
(dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags
_ <- setSessionDynFlags dynflags
let srcs = map unLoc locSrcs
unknown_opts = [ f | f@('-':_) <- srcs ]
case unknown_opts of
opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'"))
_ -> return srcs
setHaddockMode :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ < 707
setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) {
#else
setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) {
#endif
hscTarget = HscNothing
, ghcMode = CompManager
, ghcLink = NoLink
}