{-# LANGUAGE CPP #-}
module Test.DocTest.Internal.GhcUtil (withGhc) where

import           GHC.Paths (libdir)
import           GHC
import           GHC.Driver.Session (gopt_set)

import           GHC.Utils.Panic (throwGhcException)

-- | Run a GHC action in Haddock mode
withGhc :: [String] -> Ghc a -> IO a
withGhc :: forall a. [String] -> Ghc a -> IO a
withGhc [String]
flags Ghc a
action = do
  flags_ <- [String] -> IO [Located String]
handleStaticFlags [String]
flags

  runGhc (Just libdir) $ do
    handleDynamicFlags flags_
    action

handleStaticFlags :: [String] -> IO [Located String]
handleStaticFlags :: [String] -> IO [Located String]
handleStaticFlags [String]
flags = [Located String] -> IO [Located String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located String] -> IO [Located String])
-> [Located String] -> IO [Located String]
forall a b. (a -> b) -> a -> b
$ (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall e. e -> Located e
noLoc ([String] -> [Located String]) -> [String] -> [Located String]
forall a b. (a -> b) -> a -> b
$ [String]
flags

handleDynamicFlags :: GhcMonad m => [Located String] -> m ()
handleDynamicFlags :: forall (m :: * -> *). GhcMonad m => [Located String] -> m ()
handleDynamicFlags [Located String]
flags = do
#if __GLASGOW_HASKELL__ >= 901
  logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  let parseDynamicFlags' = Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
parseDynamicFlags Logger
logger
#else
  let parseDynamicFlags' = parseDynamicFlags
#endif
  dynflags0 <- setHaddockMode <$> getSessionDynFlags
  (dynflags1, locSrcs, _) <- parseDynamicFlags' dynflags0 flags
  _ <- setSessionDynFlags dynflags1

  -- We basically do the same thing as `ghc/Main.hs` to distinguish
  -- "unrecognised flags" from source files.
  let srcs = (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
unLoc [Located String]
locSrcs
      unknown_opts = [ String
f | f :: String
f@(Char
'-':String
_) <- [String]
srcs ]
  case unknown_opts of
    String
opt : [String]
_ -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError (String
"unrecognized option `"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"))
    [String]
_       -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

setHaddockMode :: DynFlags -> DynFlags
setHaddockMode :: DynFlags -> DynFlags
setHaddockMode DynFlags
dynflags = (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dynflags GeneralFlag
Opt_Haddock) {
#if __GLASGOW_HASKELL__ >= 906
      backend   = noBackend
#elif __GLASGOW_HASKELL__ >= 901
      backend   = NoBackend
#else
      hscTarget = HscNothing
#endif
    , ghcMode   = CompManager
    , ghcLink   = NoLink
    }