{-# LANGUAGE FlexibleInstances, CPP, PatternSynonyms #-}
-- | All the CPP for GHC version compability should live in this module.
module HIE.Bios.Ghc.Gap (
  ghcVersion
  -- * Warnings, Doc Compat
  , makeUserStyle
  , PprStyle
  -- * Argument parsing
  , HIE.Bios.Ghc.Gap.parseTargetFiles
  -- * Ghc Monad
  , G.modifySession
  , G.reflectGhc
  , G.Session(..)
  -- * Hsc Monad
  , getHscEnv
  -- * Driver compat
  , batchMsg
  -- * HscEnv Compat
  , set_hsc_dflags
  , overPkgDbRef
  , HIE.Bios.Ghc.Gap.guessTarget
  , setNoCode
  , getModSummaries
  , mapOverIncludePaths
  , HIE.Bios.Ghc.Gap.getLogger
  -- * AST compat
  , pattern HIE.Bios.Ghc.Gap.RealSrcSpan
  -- * Exceptions
  , catch
  , bracket
  , handle
  -- * Doc Gap functions
  , pageMode
  , oneLineMode
  -- * DynFlags compat
  , initializePluginsForModSummary
  , setFrontEndHooks
  , updOptLevel
  , setWayDynamicIfHostIsDynamic
  , HIE.Bios.Ghc.Gap.gopt_set
  , HIE.Bios.Ghc.Gap.parseDynamicFlags
  -- * Platform constants
  , hostIsDynamic
  -- * misc
  , 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

----------------------------------------------------------------
----------------------------------------------------------------

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
import qualified GHC.Driver.Make as G

#if __GLASGOW_HASKELL__ > 903
import GHC.Unit.Types (UnitId)
#endif
#if __GLASGOW_HASKELL__ < 904
import qualified GHC.Driver.Main as G
#endif
#if __GLASGOW_HASKELL__ >= 907
import GHC.Types.Error (mkUnknownDiagnostic, Messages)
import GHC.Driver.Errors.Types (DriverMessage)
#endif
#if __GLASGOW_HASKELL__ < 907
import GHC.Driver.CmdLine as CmdLine
#endif

ghcVersion :: String
ghcVersion :: String
ghcVersion = VERSION_ghc

#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' :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' = Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
G.load'
#else
load' :: GhcMonad m => a -> LoadHowMuch -> Maybe G.Messager -> ModuleGraph -> m SuccessFlag
load' _ a b c = G.load' a b c
#endif

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 =
  m a -> (a -> m c) -> (a -> m b) -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
E.bracket

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 = (e -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle

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 =
  m a -> (e -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
E.catch

----------------------------------------------------------------

pattern RealSrcSpan :: G.RealSrcSpan -> G.SrcSpan
pattern $mRealSrcSpan :: forall {r}. SrcSpan -> (RealSrcSpan -> r) -> ((# #) -> r) -> r
RealSrcSpan t <- G.RealSrcSpan t _

----------------------------------------------------------------

setNoCode :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 905
setNoCode :: DynFlags -> DynFlags
setNoCode DynFlags
d = DynFlags
d { G.backend = G.noBackend }
#else
setNoCode d = d { G.backend = G.NoBackend }
#endif

----------------------------------------------------------------

set_hsc_dflags :: DynFlags -> HscEnv -> HscEnv
set_hsc_dflags :: DynFlags -> HscEnv -> HscEnv
set_hsc_dflags DynFlags
dflags HscEnv
hsc_env = HscEnv
hsc_env { G.hsc_dflags = 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 (PkgDbRef -> PackageDBFlag) -> PkgDbRef -> PackageDBFlag
forall a b. (a -> b) -> a -> b
$ case PkgDbRef
pkgConfRef of
    G.PkgDbPath String
fp -> String -> PkgDbRef
G.PkgDbPath (String -> String
f String
fp)
    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 :: forall (m :: * -> *).
GhcMonad m =>
String -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget String
a Maybe UnitId
b Maybe Phase
c = String -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe UnitId -> Maybe Phase -> m Target
G.guessTarget String
a Maybe UnitId
b Maybe Phase
c
#else
guessTarget :: GhcMonad m => String -> a -> Maybe G.Phase -> m G.Target
guessTarget a _ b = G.guessTarget a b
#endif

----------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 905
makeUserStyle :: DynFlags -> NamePprCtx -> PprStyle
#else
makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle
#endif
makeUserStyle :: DynFlags -> NamePprCtx -> PprStyle
makeUserStyle DynFlags
_dflags NamePprCtx
style = NamePprCtx -> Depth -> PprStyle
mkUserStyle NamePprCtx
style Depth
AllTheWay

----------------------------------------------------------------

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)

----------------------------------------------------------------

mapOverIncludePaths :: (FilePath -> FilePath) -> DynFlags -> DynFlags
mapOverIncludePaths :: (String -> String) -> DynFlags -> DynFlags
mapOverIncludePaths String -> String
f DynFlags
df = DynFlags
df
  { includePaths =
      G.IncludeSpecs
          (map f $ G.includePathsQuote  (includePaths df))
          (map f $ G.includePathsGlobal (includePaths df))
#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)
          (map f $ G.includePathsQuoteImplicit (includePaths df))
#endif
  }

----------------------------------------------------------------

unsetLogAction :: GhcMonad m => m ()
unsetLogAction :: forall (m :: * -> *). GhcMonad m => m ()
unsetLogAction = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    Logger
logger <- IO Logger -> m Logger
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Logger -> m Logger) -> IO Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ IO Logger
initLogger
    let env :: HscEnv
env = HscEnv
hsc_env { hsc_logger = pushLogHook (const noopLogger) logger }
    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
env

noopLogger :: LogAction
#if __GLASGOW_HASKELL__ >= 903
noopLogger :: LogAction
noopLogger = (\LogFlags
_wr MessageClass
_s SrcSpan
_ss SDoc
_m -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#else
noopLogger = (\_df _wr _s _ss _m -> return ())
#endif

-- --------------------------------------------------------
-- Doc Compat functions
-- --------------------------------------------------------

pageMode :: Ppr.Mode
pageMode :: Mode
pageMode =
  Bool -> Mode
Ppr.PageMode Bool
True

oneLineMode :: Ppr.Mode
oneLineMode :: Mode
oneLineMode = Mode
Ppr.OneLineMode

-- --------------------------------------------------------
-- DynFlags Compat functions
-- --------------------------------------------------------

numLoadedPlugins :: HscEnv -> Int
#if __GLASGOW_HASKELL__ >= 903
numLoadedPlugins :: HscEnv -> Int
numLoadedPlugins = [PluginWithArgs] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PluginWithArgs] -> Int)
-> (HscEnv -> [PluginWithArgs]) -> HscEnv -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plugins -> [PluginWithArgs]
Plugins.pluginsWithArgs (Plugins -> [PluginWithArgs])
-> (HscEnv -> Plugins) -> HscEnv -> [PluginWithArgs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Plugins
hsc_plugins
#else
numLoadedPlugins = length . Plugins.plugins
#endif

initializePluginsForModSummary :: HscEnv -> ModSummary -> IO (Int, [G.ModuleName], ModSummary)
initializePluginsForModSummary :: HscEnv -> ModSummary -> IO (Int, [ModuleName], ModSummary)
initializePluginsForModSummary HscEnv
hsc_env' ModSummary
mod_summary = do
  HscEnv
hsc_env <- HscEnv -> IO HscEnv
DynamicLoading.initializePlugins HscEnv
hsc_env'
  (Int, [ModuleName], ModSummary)
-> IO (Int, [ModuleName], ModSummary)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( HscEnv -> Int
numLoadedPlugins HscEnv
hsc_env
       , DynFlags -> [ModuleName]
pluginModNames (DynFlags -> [ModuleName]) -> DynFlags -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
       , ModSummary
mod_summary
       )

setFrontEndHooks :: Maybe (ModSummary -> G.Hsc Tc.FrontendResult) -> HscEnv -> HscEnv
setFrontEndHooks :: Maybe (ModSummary -> Hsc FrontendResult) -> HscEnv -> HscEnv
setFrontEndHooks Maybe (ModSummary -> Hsc FrontendResult)
frontendHook HscEnv
env =
  HscEnv
env
    { hsc_hooks = hooks
        { hscFrontendHook = frontendHook
        }
    }
  where
    hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
env

getLogger :: HscEnv -> Logger
getLogger :: HscEnv -> Logger
getLogger =
    HscEnv -> Logger
hsc_logger

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 (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> DynFlags -> DynFlags
addWay' Way
WayDyn
    else
      DynFlags -> DynFlags
forall a. a -> a
id

updateWays :: DynFlags -> DynFlags
updateWays :: DynFlags -> DynFlags
updateWays = DynFlags -> DynFlags
forall a. a -> a
id

-- Copied from GHC, do we need that?
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_ = Platform.addWay w (targetWays_ dflags0) }
       dflags2 :: DynFlags
dflags2 = (GeneralFlag -> DynFlags -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
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 = (GeneralFlag -> DynFlags -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
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

parseDynamicFlags :: MonadIO m
    => Logger
    -> DynFlags
    -> [G.Located String]
    -> m (DynFlags, [G.Located String]
#if __GLASGOW_HASKELL__ >= 907
          , Messages DriverMessage)
#else
          , [CmdLine.Warn])
#endif
parseDynamicFlags :: forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags = Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
G.parseDynamicFlags


parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe G.Phase)], [String])
parseTargetFiles :: DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles = DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
G.parseTargetFiles

-- --------------------------------------------------------
-- Platform constants
-- --------------------------------------------------------

hostIsDynamic :: Bool
hostIsDynamic :: Bool
hostIsDynamic = Bool
Platform.hostIsDynamic