{-# LANGUAGE CPP #-}
module GhcUtil (withGhc) where
import GHC.Paths (libdir)
import GHC
#if __GLASGOW_HASKELL__ < 900
import DynFlags (gopt_set)
#else
import GHC.Driver.Session (gopt_set)
#endif
#if __GLASGOW_HASKELL__ < 900
import Panic (throwGhcException)
#else
import GHC.Utils.Panic (throwGhcException)
#endif
#if __GLASGOW_HASKELL__ < 900
import MonadUtils (liftIO)
#else
import GHC.Utils.Monad (liftIO)
#endif
import System.Exit (exitFailure)
#if __GLASGOW_HASKELL__ < 801
import StaticFlags (discardStaticFlags)
#endif
handleSrcErrors :: Ghc a -> Ghc a
handleSrcErrors :: forall a. Ghc a -> Ghc a
handleSrcErrors Ghc a
action' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError Ghc a
action' forall a b. (a -> b) -> a -> b
$ \SourceError
err -> do
forall (m :: * -> *). GhcMonad m => SourceError -> m ()
printException SourceError
err
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure
withGhc :: [String] -> ([String] -> Ghc a) -> IO a
withGhc :: forall a. [String] -> ([String] -> Ghc a) -> IO a
withGhc [String]
flags [String] -> Ghc a
action = do
[Located String]
flags_ <- [String] -> IO [Located String]
handleStaticFlags [String]
flags
forall a. Maybe String -> Ghc a -> IO a
runGhc (forall a. a -> Maybe a
Just String
libdir) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). GhcMonad m => [Located String] -> m [String]
handleDynamicFlags [Located String]
flags_ forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Ghc a -> Ghc a
handleSrcErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Ghc a
action
handleStaticFlags :: [String] -> IO [Located String]
#if __GLASGOW_HASKELL__ < 801
handleStaticFlags flags = return $ map noLoc $ discardStaticFlags flags
#else
handleStaticFlags :: [String] -> IO [Located String]
handleStaticFlags [String]
flags = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ [String]
flags
#endif
handleDynamicFlags :: GhcMonad m => [Located String] -> m [String]
handleDynamicFlags :: forall (m :: * -> *). GhcMonad m => [Located String] -> m [String]
handleDynamicFlags [Located String]
flags = do
#if __GLASGOW_HASKELL__ >= 901
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
let parseDynamicFlags' :: DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags' = forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags Logger
logger
#else
let parseDynamicFlags' = parseDynamicFlags
#endif
(DynFlags
dynflags, [Located String]
locSrcs, [Warn]
_) <- (DynFlags -> DynFlags
setHaddockMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
`parseDynamicFlags'` [Located String]
flags)
()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
dynflags
let srcs :: [String]
srcs = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [Located String]
locSrcs
unknown_opts :: [String]
unknown_opts = [ String
f | f :: String
f@(Char
'-':String
_) <- [String]
srcs ]
case [String]
unknown_opts of
String
opt : [String]
_ -> forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError (String
"unrecognized option `"forall a. [a] -> [a] -> [a]
++ String
opt forall a. [a] -> [a] -> [a]
++ String
"'"))
[String]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [String]
srcs
setHaddockMode :: DynFlags -> DynFlags
setHaddockMode :: DynFlags -> DynFlags
setHaddockMode DynFlags
dynflags = (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dynflags GeneralFlag
Opt_Haddock) {
#if __GLASGOW_HASKELL__ >= 901
backend :: Backend
backend = Backend
NoBackend
#else
hscTarget = HscNothing
#endif
, ghcMode :: GhcMode
ghcMode = GhcMode
CompManager
, ghcLink :: GhcLink
ghcLink = GhcLink
NoLink
}