{-# LANGUAGE FlexibleInstances, CPP, PatternSynonyms #-}
module HIE.Bios.Ghc.Gap (
ghcVersion
, makeUserStyle
, PprStyle
, HIE.Bios.Ghc.Gap.parseTargetFiles
, G.modifySession
, G.reflectGhc
, G.Session(..)
, getHscEnv
, batchMsg
, set_hsc_dflags
, overPkgDbRef
, HIE.Bios.Ghc.Gap.guessTarget
, setNoCode
, getModSummaries
, mapOverIncludePaths
, HIE.Bios.Ghc.Gap.getLogger
, pattern HIE.Bios.Ghc.Gap.RealSrcSpan
, catch
, bracket
, handle
, pageMode
, oneLineMode
, initializePluginsForModSummary
, setFrontEndHooks
, updOptLevel
, setWayDynamicIfHostIsDynamic
, HIE.Bios.Ghc.Gap.gopt_set
, HIE.Bios.Ghc.Gap.parseDynamicFlags
, hostIsDynamic
, getTyThing
, fixInfo
, Tc.FrontendResult(..)
, Hsc
, mapMG
, mgModSummaries
, unsetLogAction
, load'
, homeUnitId_
, getDynFlags
) where
import Control.Monad.IO.Class
import qualified Control.Monad.Catch as E
import GHC
import qualified GHC as G
#if __GLASGOW_HASKELL__ >= 810 && __GLASGOW_HASKELL__ < 900
import Data.List
import System.FilePath
import DynFlags (LogAction, WarningFlag, updOptLevel, Way(WayDyn), updateWays, addWay', getDynFlags)
import qualified DynFlags as G
import qualified Exception as G
import Outputable (PprStyle, Depth(AllTheWay), mkUserStyle)
import HscMain (getHscEnv, batchMsg)
import HscTypes (Hsc, HscEnv(..))
import qualified HscTypes as G
import qualified EnumSet as E (EnumSet, empty)
import qualified Pretty as Ppr
import qualified TcRnTypes as Tc
import Hooks (Hooks(hscFrontendHook))
import qualified CmdLineParser as CmdLine
import DriverPhases as G
import Util as G
import qualified GhcMonad as G
import qualified DynamicLoading (initializePlugins)
import qualified Plugins (plugins)
#endif
#if __GLASGOW_HASKELL__ >= 902
import GHC.Driver.CmdLine as CmdLine
import GHC.Driver.Env as G
import GHC.Driver.Session as G
import GHC.Driver.Hooks
import GHC.Driver.Main
import GHC.Driver.Monad as G
import qualified GHC.Driver.Plugins as Plugins
import GHC.Platform.Ways (Way(WayDyn))
import qualified GHC.Platform.Ways as Platform
import qualified GHC.Runtime.Loader as DynamicLoading (initializePlugins)
import qualified GHC.Tc.Types as Tc
import GHC.Utils.Logger
import GHC.Utils.Outputable
import qualified GHC.Utils.Ppr as Ppr
#elif __GLASGOW_HASKELL__ >= 900
import Data.List
import System.FilePath
import GHC.Core.Multiplicity (irrelevantMult)
import GHC.Data.EnumSet as E
import GHC.Driver.CmdLine as CmdLine
import GHC.Driver.Types as G
import GHC.Driver.Session as G
import GHC.Driver.Hooks
import GHC.Driver.Main
import GHC.Driver.Monad as G
import GHC.Driver.Phases as G
import GHC.Utils.Misc as G
import qualified GHC.Driver.Plugins as Plugins
import GHC.Driver.Ways (Way(WayDyn))
import qualified GHC.Driver.Ways as Platform
import qualified GHC.Runtime.Loader as DynamicLoading (initializePlugins)
import qualified GHC.Tc.Types as Tc
import GHC.Utils.Outputable
import qualified GHC.Utils.Ppr as Ppr
#endif
#if __GLASGOW_HASKELL__ >= 900
import GHC.Unit.Types (UnitId)
#endif
#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Driver.Main as G
import qualified GHC.Driver.Make as G
#else
import qualified HscMain as G
import qualified GhcMake as G
#endif
#if __GLASGOW_HASKELL__ >= 907
import GHC.Types.Error (mkUnknownDiagnostic, Messages)
import GHC.Driver.Errors.Types (DriverMessage)
#endif
ghcVersion :: String
ghcVersion :: String
ghcVersion = VERSION_ghc
#if __GLASGOW_HASKELL__ <= 810
homeUnitId_ :: a -> ()
homeUnitId_ = const ()
#elif __GLASGOW_HASKELL__ <= 901
homeUnitId_ :: DynFlags -> UnitId
homeUnitId_ = homeUnitId
#endif
#if __GLASGOW_HASKELL__ >= 907
load' :: GhcMonad m => Maybe G.ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' mhmi_cache how_much = G.load' mhmi_cache how_much mkUnknownDiagnostic
#elif __GLASGOW_HASKELL__ >= 904
load' :: GhcMonad m => Maybe G.ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' = G.load'
#else
load' :: GhcMonad m => a -> LoadHowMuch -> Maybe G.Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *) a.
GhcMonad m =>
a -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' a
_ LoadHowMuch
a Maybe Messager
b ModuleGraph
c = forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
G.load' LoadHowMuch
a Maybe Messager
b ModuleGraph
c
#endif
#if __GLASGOW_HASKELL__ >= 900
bracket :: E.MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b
bracket :: forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket =
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
E.bracket
#else
bracket :: G.ExceptionMonad m => m a -> (a -> m c) -> (a -> m b) -> m b
bracket =
G.gbracket
#endif
#if __GLASGOW_HASKELL__ >= 900
handle :: (E.MonadCatch m, E.Exception e) => (e -> m a) -> m a -> m a
handle :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle
#else
handle :: (G.ExceptionMonad m, E.Exception e) => (e -> m a) -> m a -> m a
handle = G.ghandle
#endif
catch :: (E.MonadCatch m, E.Exception e) => m a -> (e -> m a) -> m a
catch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch =
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch
pattern RealSrcSpan :: G.RealSrcSpan -> G.SrcSpan
#if __GLASGOW_HASKELL__ >= 900
pattern $mRealSrcSpan :: forall {r}. SrcSpan -> (RealSrcSpan -> r) -> ((# #) -> r) -> r
RealSrcSpan t <- G.RealSrcSpan t _
#else
pattern RealSrcSpan t <- G.RealSrcSpan t
#endif
setNoCode :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 905
setNoCode d = d { G.backend = G.noBackend }
#elif __GLASGOW_HASKELL__ >= 901
setNoCode :: DynFlags -> DynFlags
setNoCode DynFlags
d = DynFlags
d { backend :: Backend
G.backend = Backend
G.NoBackend }
#else
setNoCode d = d { G.hscTarget = G.HscNothing }
#endif
set_hsc_dflags :: DynFlags -> HscEnv -> HscEnv
set_hsc_dflags :: DynFlags -> HscEnv -> HscEnv
set_hsc_dflags DynFlags
dflags HscEnv
hsc_env = HscEnv
hsc_env { hsc_dflags :: DynFlags
G.hsc_dflags = DynFlags
dflags }
overPkgDbRef :: (FilePath -> FilePath) -> G.PackageDBFlag -> G.PackageDBFlag
overPkgDbRef :: (String -> String) -> PackageDBFlag -> PackageDBFlag
overPkgDbRef String -> String
f (G.PackageDB PkgDbRef
pkgConfRef) = PkgDbRef -> PackageDBFlag
G.PackageDB
forall a b. (a -> b) -> a -> b
$ case PkgDbRef
pkgConfRef of
#if __GLASGOW_HASKELL__ >= 900
G.PkgDbPath String
fp -> String -> PkgDbRef
G.PkgDbPath (String -> String
f String
fp)
#else
G.PkgConfFile fp -> G.PkgConfFile (f fp)
#endif
PkgDbRef
conf -> PkgDbRef
conf
overPkgDbRef String -> String
_f PackageDBFlag
db = PackageDBFlag
db
#if __GLASGOW_HASKELL__ >= 903
guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe G.Phase -> m G.Target
guessTarget a b c = G.guessTarget a b c
#else
guessTarget :: GhcMonad m => String -> a -> Maybe G.Phase -> m G.Target
guessTarget :: forall (m :: * -> *) a.
GhcMonad m =>
String -> a -> Maybe Phase -> m Target
guessTarget String
a a
_ Maybe Phase
b = forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
G.guessTarget String
a Maybe Phase
b
#endif
#if __GLASGOW_HASKELL__ >= 905
makeUserStyle :: DynFlags -> NamePprCtx -> PprStyle
#else
makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle
#endif
#if __GLASGOW_HASKELL__ >= 900
makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle
makeUserStyle DynFlags
_dflags PrintUnqualified
style = PrintUnqualified -> Depth -> PprStyle
mkUserStyle PrintUnqualified
style Depth
AllTheWay
#elif __GLASGOW_HASKELL__ >= 804
makeUserStyle dflags style = mkUserStyle dflags style AllTheWay
#endif
#if __GLASGOW_HASKELL__ >= 810
getModSummaries :: ModuleGraph -> [ModSummary]
getModSummaries :: ModuleGraph -> [ModSummary]
getModSummaries = ModuleGraph -> [ModSummary]
mgModSummaries
getTyThing :: (a, b, c, d, e) -> a
getTyThing :: forall a b c d e. (a, b, c, d, e) -> a
getTyThing (a
t,b
_,c
_,d
_,e
_) = a
t
fixInfo :: (a, b, c, d, e) -> (a, b, c, d)
fixInfo :: forall a b c d e. (a, b, c, d, e) -> (a, b, c, d)
fixInfo (a
t,b
f,c
cs,d
fs,e
_) = (a
t,b
f,c
cs,d
fs)
#endif
mapOverIncludePaths :: (FilePath -> FilePath) -> DynFlags -> DynFlags
mapOverIncludePaths :: (String -> String) -> DynFlags -> DynFlags
mapOverIncludePaths String -> String
f DynFlags
df = DynFlags
df
{ includePaths :: IncludeSpecs
includePaths =
#if __GLASGOW_HASKELL__ >= 810
[String] -> [String] -> [String] -> IncludeSpecs
G.IncludeSpecs
(forall a b. (a -> b) -> [a] -> [b]
map String -> String
f forall a b. (a -> b) -> a -> b
$ IncludeSpecs -> [String]
G.includePathsQuote (DynFlags -> IncludeSpecs
includePaths DynFlags
df))
(forall a b. (a -> b) -> [a] -> [b]
map String -> String
f forall a b. (a -> b) -> a -> b
$ IncludeSpecs -> [String]
G.includePathsGlobal (DynFlags -> IncludeSpecs
includePaths DynFlags
df))
#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)
(forall a b. (a -> b) -> [a] -> [b]
map String -> String
f forall a b. (a -> b) -> a -> b
$ IncludeSpecs -> [String]
G.includePathsQuoteImplicit (DynFlags -> IncludeSpecs
includePaths DynFlags
df))
#endif
#endif
}
unsetLogAction :: GhcMonad m => m ()
unsetLogAction :: forall (m :: * -> *). GhcMonad m => m ()
unsetLogAction = do
#if __GLASGOW_HASKELL__ >= 902
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Logger
logger <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO Logger
initLogger
let env :: HscEnv
env = HscEnv
hsc_env { hsc_logger :: Logger
hsc_logger = (LogAction -> LogAction) -> Logger -> Logger
pushLogHook (forall a b. a -> b -> a
const LogAction
noopLogger) Logger
logger }
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
env
#else
setLogAction noopLogger
#if __GLASGOW_HASKELL__ < 806
(\_df -> return ())
#endif
#endif
noopLogger :: LogAction
#if __GLASGOW_HASKELL__ >= 903
noopLogger = (\_wr _s _ss _m -> return ())
#elif __GLASGOW_HASKELL__ >= 900
noopLogger :: LogAction
noopLogger = (\DynFlags
_df WarnReason
_wr Severity
_s SrcSpan
_ss SDoc
_m -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
#else
noopLogger = (\_df _wr _s _ss _pp _m -> return ())
#endif
pageMode :: Ppr.Mode
pageMode :: Mode
pageMode =
#if __GLASGOW_HASKELL__ >= 902
Bool -> Mode
Ppr.PageMode Bool
True
#else
Ppr.PageMode
#endif
oneLineMode :: Ppr.Mode
oneLineMode :: Mode
oneLineMode = Mode
Ppr.OneLineMode
numLoadedPlugins :: HscEnv -> Int
#if __GLASGOW_HASKELL__ >= 903
numLoadedPlugins = length . Plugins.pluginsWithArgs . hsc_plugins
#elif __GLASGOW_HASKELL__ >= 902
numLoadedPlugins :: HscEnv -> Int
numLoadedPlugins = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> [PluginWithArgs]
Plugins.plugins
#elif __GLASGOW_HASKELL__ >= 808
numLoadedPlugins = length . Plugins.plugins . hsc_dflags
#else
numLoadedPlugins _ = 0
#endif
initializePluginsForModSummary :: HscEnv -> ModSummary -> IO (Int, [G.ModuleName], ModSummary)
initializePluginsForModSummary :: HscEnv -> ModSummary -> IO (Int, [ModuleName], ModSummary)
initializePluginsForModSummary HscEnv
hsc_env' ModSummary
mod_summary = do
#if __GLASGOW_HASKELL__ >= 902
HscEnv
hsc_env <- HscEnv -> IO HscEnv
DynamicLoading.initializePlugins HscEnv
hsc_env'
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( HscEnv -> Int
numLoadedPlugins HscEnv
hsc_env
, DynFlags -> [ModuleName]
pluginModNames forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
, ModSummary
mod_summary
)
#elif __GLASGOW_HASKELL__ >= 808
let dynFlags' = G.ms_hspp_opts mod_summary
dynFlags <- DynamicLoading.initializePlugins hsc_env' dynFlags'
pure ( numLoadedPlugins $ set_hsc_dflags dynFlags hsc_env'
, G.pluginModNames dynFlags
, mod_summary { G.ms_hspp_opts = dynFlags }
)
#else
return (numLoadedPlugins hsc_env', G.pluginModNames $ hsc_dflags hsc_env', mod_summary)
#endif
setFrontEndHooks :: Maybe (ModSummary -> G.Hsc Tc.FrontendResult) -> HscEnv -> HscEnv
setFrontEndHooks :: Maybe (ModSummary -> Hsc FrontendResult) -> HscEnv -> HscEnv
setFrontEndHooks Maybe (ModSummary -> Hsc FrontendResult)
frontendHook HscEnv
env =
#if __GLASGOW_HASKELL__ >= 902
HscEnv
env
{ hsc_hooks :: Hooks
hsc_hooks = Hooks
hooks
{ hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook = Maybe (ModSummary -> Hsc FrontendResult)
frontendHook
}
}
where
hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
env
#else
env
{ G.hsc_dflags = flags
{ G.hooks = oldhooks
{ hscFrontendHook = frontendHook
}
}
}
where
flags = hsc_dflags env
oldhooks = G.hooks flags
#endif
#if __GLASGOW_HASKELL__ < 902
type Logger = ()
#endif
getLogger :: HscEnv -> Logger
getLogger :: HscEnv -> Logger
getLogger =
#if __GLASGOW_HASKELL__ >= 902
HscEnv -> Logger
hsc_logger
#else
const ()
#endif
gopt_set :: DynFlags -> G.GeneralFlag -> DynFlags
gopt_set :: DynFlags -> GeneralFlag -> DynFlags
gopt_set = DynFlags -> GeneralFlag -> DynFlags
G.gopt_set
setWayDynamicIfHostIsDynamic :: DynFlags -> DynFlags
setWayDynamicIfHostIsDynamic :: DynFlags -> DynFlags
setWayDynamicIfHostIsDynamic =
if Bool
hostIsDynamic
then
DynFlags -> DynFlags
updateWays forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> DynFlags -> DynFlags
addWay' Way
WayDyn
else
forall a. a -> a
id
#if __GLASGOW_HASKELL__ >= 900
updateWays :: DynFlags -> DynFlags
updateWays :: DynFlags -> DynFlags
updateWays = forall a. a -> a
id
#if __GLASGOW_HASKELL__ >= 902
addWay' :: Way -> DynFlags -> DynFlags
addWay' :: Way -> DynFlags -> DynFlags
addWay' Way
w DynFlags
dflags0 =
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags0
dflags1 :: DynFlags
dflags1 = DynFlags
dflags0 { targetWays_ :: Ways
targetWays_ = Way -> Ways -> Ways
Platform.addWay Way
w (DynFlags -> Ways
targetWays_ DynFlags
dflags0) }
dflags2 :: DynFlags
dflags2 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GeneralFlag -> DynFlags -> DynFlags
setGeneralFlag' DynFlags
dflags1
(Platform -> Way -> [GeneralFlag]
Platform.wayGeneralFlags Platform
platform Way
w)
dflags3 :: DynFlags
dflags3 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GeneralFlag -> DynFlags -> DynFlags
unSetGeneralFlag' DynFlags
dflags2
(Platform -> Way -> [GeneralFlag]
Platform.wayUnsetGeneralFlags Platform
platform Way
w)
in DynFlags
dflags3
#endif
#endif
parseDynamicFlags :: MonadIO m
=> Logger
-> DynFlags
-> [G.Located String]
-> m (DynFlags, [G.Located String]
#if __GLASGOW_HASKELL__ >= 907
, Messages DriverMessage)
#else
, [CmdLine.Warn])
#endif
#if __GLASGOW_HASKELL__ >= 902
parseDynamicFlags :: forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags = forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
G.parseDynamicFlags
#else
parseDynamicFlags _ = G.parseDynamicFlags
#endif
parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe G.Phase)], [String])
#if __GLASGOW_HASKELL__ >= 902
parseTargetFiles :: DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles = DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
G.parseTargetFiles
#else
parseTargetFiles dflags0 fileish_args =
let
normalise_hyp fp
| strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
| otherwise = nfp
where
#if defined(mingw32_HOST_OS)
strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
strt_dot_sl = "./" `isPrefixOf` fp
#endif
cur_dir = '.' : [pathSeparator]
nfp = normalise fp
normal_fileish_paths = map normalise_hyp fileish_args
(srcs, objs) = partition_args normal_fileish_paths [] []
df1 = dflags0 { G.ldInputs = map (G.FileOption "") objs ++ G.ldInputs dflags0 }
in
(df1, srcs, objs)
#endif
#if __GLASGOW_HASKELL__ < 902
partition_args :: [String] -> [(String, Maybe G.Phase)] -> [String]
-> ([(String, Maybe G.Phase)], [String])
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
| "none" <- suff = partition_args args srcs objs
| G.StopLn <- phase = partition_args args srcs (slurp ++ objs)
| otherwise = partition_args rest (these_srcs ++ srcs) objs
where phase = G.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)
looks_like_an_input :: String -> Bool
looks_like_an_input m = G.isSourceFilename m
|| G.looksLikeModuleName m
|| "-" `isPrefixOf` m
|| not (hasExtension m)
#endif
hostIsDynamic :: Bool
#if __GLASGOW_HASKELL__ >= 900
hostIsDynamic :: Bool
hostIsDynamic = Bool
Platform.hostIsDynamic
#else
hostIsDynamic = G.dynamicGhc
#endif