GHC.hs

module Hint.GHC (
    -- * Shims
    dynamicGhc,
    Message,
    Logger,
    initLogger,
    putLogMsg,
    pushLogHook,
    modifyLogger,
    UnitState,
    emptyUnitState,
    showSDocForUser,
    ParserOpts,
    mkParserOpts,
    initParserState,
    getErrorMessages,
    pprErrorMessages,
    SDocContext,
    defaultSDocContext,
    showGhcException,
    addWay,
    setBackendToInterpreter,
    parseDynamicFlags,
    -- * Re-exports
    module X,
) where

import GHC as X hiding (Phase, GhcT, parseDynamicFlags, runGhcT, showGhcException
#if MIN_VERSION_ghc(9,2,0)
                       , Logger
                       , modifyLogger
                       , pushLogHook
#endif
                       )
import Control.Monad.Ghc as X (GhcT, runGhcT)

#if MIN_VERSION_ghc(9,2,0)
import GHC.Types.SourceError as X (SourceError, srcErrorMessages)

import GHC.Driver.Ppr as X (showSDoc)

import GHC.Types.SourceFile as X (HscSource(HsSrcFile))

import GHC.Utils.Logger as X (LogAction)
import GHC.Platform.Ways as X (Way (..))

import GHC.Types.TyThing.Ppr as X (pprTypeForUser)
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Driver.Types as X (SourceError, srcErrorMessages, GhcApiError)

import GHC.Utils.Outputable as X (showSDoc)

import GHC.Driver.Phases as X (HscSource(HsSrcFile))

import GHC.Driver.Session as X (LogAction, addWay')
import GHC.Driver.Ways as X (Way (..))

import GHC.Core.Ppr.TyThing as X (pprTypeForUser)
#else
import HscTypes as X (SourceError, srcErrorMessages, GhcApiError)

import Outputable as X (showSDoc)

import DriverPhases as X (HscSource(HsSrcFile))

import DynFlags as X (LogAction, addWay', Way(..))

import PprTyThing as X (pprTypeForUser)
#endif

#if MIN_VERSION_ghc(9,0,0)
import GHC.Utils.Outputable as X (PprStyle, SDoc, Outputable(ppr),
                                  withPprStyle, defaultErrStyle, vcat)

import GHC.Utils.Error as X (mkLocMessage, errMsgSpan)

import GHC.Driver.Phases as X (Phase(Cpp))
import GHC.Data.StringBuffer as X (stringToStringBuffer)
import GHC.Parser.Lexer as X (P(..), ParseResult(..))
import GHC.Parser as X (parseStmt, parseType)
import GHC.Data.FastString as X (fsLit)

import GHC.Driver.Session as X (xFlags, xopt, FlagSpec(..), WarnReason(NoReason))

import GHC.Types.SrcLoc as X (combineSrcSpans, mkRealSrcLoc)

import GHC.Core.ConLike as X (ConLike(RealDataCon))
#else
import HscTypes as X (mgModSummaries)

import Outputable as X (PprStyle, SDoc, Outputable(ppr),
                        withPprStyle, defaultErrStyle, vcat)

import ErrUtils as X (mkLocMessage, errMsgSpan)

import DriverPhases as X (Phase(Cpp))
import StringBuffer as X (stringToStringBuffer)
import Lexer as X (P(..), ParseResult(..), mkPState)
import Parser as X (parseStmt, parseType)
import FastString as X (fsLit)

import DynFlags as X (xFlags, xopt, FlagSpec(..), WarnReason(NoReason))

import SrcLoc as X (combineSrcSpans, mkRealSrcLoc)

import ConLike as X (ConLike(RealDataCon))
#endif

{-------------------- Imports for Shims --------------------}

import Control.Monad.IO.Class (MonadIO)

#if MIN_VERSION_ghc(9,2,0)
-- dynamicGhc
import GHC.Platform.Ways (hostIsDynamic)

-- Logger
import qualified GHC.Utils.Logger as GHC (Logger, initLogger, putLogMsg, pushLogHook)
import qualified GHC.Driver.Monad as GHC (modifyLogger)

-- UnitState
import qualified GHC.Unit.State as GHC (UnitState, emptyUnitState)

-- showSDocForUser
import qualified GHC.Driver.Ppr as GHC (showSDocForUser)

-- PState
import qualified GHC.Parser.Lexer as GHC (PState, ParserOpts, mkParserOpts, initParserState)
import GHC.Data.StringBuffer (StringBuffer)
import qualified GHC.Driver.Session as DynFlags (warningFlags, extensionFlags, safeImportsOn)

-- ErrorMessages
import qualified GHC.Parser.Errors.Ppr as GHC (pprError)
import qualified GHC.Parser.Lexer as GHC (getErrorMessages)
import qualified GHC.Types.Error as GHC (ErrorMessages, errMsgDiagnostic, unDecorated)
import GHC.Data.Bag (bagToList)

-- showGhcException
import qualified GHC (showGhcException)
import qualified GHC.Utils.Outputable as GHC (SDocContext, defaultSDocContext)

-- addWay
import qualified GHC.Driver.Session as DynFlags (targetWays_)
import qualified Data.Set as Set

-- parseDynamicFlags
import qualified GHC (parseDynamicFlags)
import GHC.Driver.CmdLine (Warn)
#elif MIN_VERSION_ghc(9,0,0)
-- dynamicGhc
import GHC.Driver.Ways (hostIsDynamic)

-- Message
import qualified GHC.Utils.Error as GHC (MsgDoc)

-- Logger
import qualified GHC.Driver.Session as GHC (defaultLogAction)
import qualified GHC.Driver.Session as DynFlags (log_action)

-- showSDocForUser
import qualified GHC.Utils.Outputable as GHC (showSDocForUser)

-- PState
import qualified GHC.Parser.Lexer as GHC (PState, ParserFlags, mkParserFlags, mkPStatePure)
import GHC.Data.StringBuffer (StringBuffer)

-- ErrorMessages
import qualified GHC.Utils.Error as GHC (ErrorMessages, pprErrMsgBagWithLoc)
import qualified GHC.Parser.Lexer as GHC (getErrorMessages)

-- showGhcException
import qualified GHC (showGhcException)

-- addWay
import qualified GHC.Driver.Session as GHC (addWay')

-- parseDynamicFlags
import qualified GHC (parseDynamicFlags)
import GHC.Driver.CmdLine (Warn)
#else
-- dynamicGhc
import qualified DynFlags as GHC (dynamicGhc)

-- Message
import qualified ErrUtils as GHC (MsgDoc)

-- Logger
import qualified DynFlags as GHC (defaultLogAction)
import qualified DynFlags (log_action)

-- showSDocForUser
import qualified Outputable as GHC (showSDocForUser)

-- PState
import qualified Lexer as GHC (PState, ParserFlags, mkParserFlags, mkPStatePure)
import StringBuffer (StringBuffer)

-- ErrorMessages
import qualified ErrUtils as GHC (ErrorMessages, pprErrMsgBagWithLoc)
#if MIN_VERSION_ghc(8,10,0)
import qualified Lexer as GHC (getErrorMessages)
#else
import Bag (emptyBag)
#endif

-- showGhcException
import qualified GHC (showGhcException)

-- addWay
import qualified DynFlags as GHC (addWay')

-- parseDynamicFlags
import qualified GHC (parseDynamicFlags)
import CmdLineParser (Warn)
#endif

{-------------------- Shims --------------------}

-- dynamicGhc
dynamicGhc :: Bool
#if MIN_VERSION_ghc(9,0,0)
dynamicGhc = hostIsDynamic
#else
dynamicGhc = GHC.dynamicGhc
#endif

-- Message
#if MIN_VERSION_ghc(9,2,0)
type Message = SDoc
#else
type Message = GHC.MsgDoc
#endif

-- Logger
initLogger :: IO Logger
putLogMsg :: Logger -> LogAction
pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()
#if MIN_VERSION_ghc(9,2,0)
type Logger = GHC.Logger
initLogger = GHC.initLogger
putLogMsg = GHC.putLogMsg
pushLogHook = GHC.pushLogHook
modifyLogger = GHC.modifyLogger
#else
type Logger = LogAction
initLogger = pure GHC.defaultLogAction
putLogMsg = id
pushLogHook = id
modifyLogger f = do
  df <- getSessionDynFlags
  _ <- setSessionDynFlags df{log_action = f $ DynFlags.log_action df}
  return ()
#endif

-- UnitState
emptyUnitState :: UnitState
#if MIN_VERSION_ghc(9,2,0)
type UnitState = GHC.UnitState
emptyUnitState = GHC.emptyUnitState
#else
type UnitState = ()
emptyUnitState = ()
#endif

-- showSDocForUser
showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String
#if MIN_VERSION_ghc(9,2,0)
showSDocForUser = GHC.showSDocForUser
#else
showSDocForUser df _ = GHC.showSDocForUser df
#endif

-- PState
mkParserOpts :: DynFlags -> ParserOpts
initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> GHC.PState
#if MIN_VERSION_ghc(9,2,0)
type ParserOpts = GHC.ParserOpts
mkParserOpts =
  -- adapted from
  -- https://hackage.haskell.org/package/ghc-8.10.2/docs/src/Lexer.html#line-2437
  GHC.mkParserOpts
    <$> DynFlags.warningFlags
    <*> DynFlags.extensionFlags
    <*> DynFlags.safeImportsOn
    <*> gopt Opt_Haddock
    <*> gopt Opt_KeepRawTokenStream
    <*> const True

initParserState = GHC.initParserState
#else
type ParserOpts = GHC.ParserFlags
mkParserOpts = GHC.mkParserFlags

initParserState = GHC.mkPStatePure
#endif

-- ErrorMessages
getErrorMessages :: GHC.PState -> DynFlags -> GHC.ErrorMessages
pprErrorMessages :: GHC.ErrorMessages -> [SDoc]
#if MIN_VERSION_ghc(9,2,0)
getErrorMessages pstate _ = fmap GHC.pprError $ GHC.getErrorMessages pstate
pprErrorMessages = bagToList . fmap pprErrorMessage
  where
    pprErrorMessage = vcat . GHC.unDecorated . GHC.errMsgDiagnostic
#elif MIN_VERSION_ghc(8,10,0)
getErrorMessages = GHC.getErrorMessages
pprErrorMessages = GHC.pprErrMsgBagWithLoc
#else
getErrorMessages _ _ = emptyBag
pprErrorMessages = GHC.pprErrMsgBagWithLoc
#endif

-- SDocContext
defaultSDocContext :: SDocContext
#if MIN_VERSION_ghc(9,2,0)
type SDocContext = GHC.SDocContext
defaultSDocContext = GHC.defaultSDocContext
#else
type SDocContext = ()
defaultSDocContext = ()
#endif

-- showGhcException
showGhcException :: SDocContext -> GhcException -> ShowS
#if MIN_VERSION_ghc(9,2,0)
showGhcException = GHC.showGhcException
#else
showGhcException _ = GHC.showGhcException
#endif

-- addWay
addWay :: Way -> DynFlags -> DynFlags
#if MIN_VERSION_ghc(9,2,0)
addWay way df =
  df
    { targetWays_ = Set.insert way $ DynFlags.targetWays_ df
    }
#else
addWay = GHC.addWay'
#endif

-- setBackendToInterpreter
setBackendToInterpreter :: DynFlags -> DynFlags
#if MIN_VERSION_ghc(9,2,0)
setBackendToInterpreter df = df{backend = Interpreter}
#else
setBackendToInterpreter df = df{hscTarget = HscInterpreted}
#endif

-- parseDynamicFlags
parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn])
#if MIN_VERSION_ghc(9,2,0)
parseDynamicFlags = GHC.parseDynamicFlags
#else
parseDynamicFlags _ = GHC.parseDynamicFlags
#endif