-- ============================================================================
-- DO NOT EDIT
-- This module copies parts of the driver code in GHC.Driver.Main to provide
-- `hscTypecheckRenameWithDiagnostics`.
-- Issue to add this function: https://gitlab.haskell.org/ghc/ghc/-/issues/24996
-- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891
-- ============================================================================

{-# LANGUAGE CPP #-}

module Development.IDE.GHC.Compat.Driver
    ( hscTypecheckRenameWithDiagnostics
    ) where

#if MIN_VERSION_ghc(9,11,0)

import           GHC.Driver.Main            (hscTypecheckRenameWithDiagnostics)

#else

import           Control.Monad
import           GHC.Core
import           GHC.Data.FastString
import           GHC.Data.Maybe
import           GHC.Driver.Env
import           GHC.Driver.Errors.Types
import           GHC.Driver.Main
import           GHC.Driver.Session
import           GHC.Hs
import           GHC.Hs.Dump
import           GHC.Iface.Ext.Ast          (mkHieFile)
import           GHC.Iface.Ext.Binary       (hie_file_result, readHieFile,
                                             writeHieFile)
import           GHC.Iface.Ext.Debug        (diffFile, validateScopes)
import           GHC.Iface.Ext.Types        (getAsts, hie_asts, hie_module)
import           GHC.Tc.Module
import           GHC.Tc.Utils.Monad
import           GHC.Types.SourceFile
import           GHC.Types.SrcLoc
import           GHC.Unit
import           GHC.Unit.Module.ModDetails
import           GHC.Unit.Module.ModIface
import           GHC.Unit.Module.ModSummary
import           GHC.Utils.Error
import           GHC.Utils.Logger
import           GHC.Utils.Outputable
import           GHC.Utils.Panic.Plain

hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule
                   -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
hscTypecheckRenameWithDiagnostics :: HscEnv
-> ModSummary
-> HsParsedModule
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
hscTypecheckRenameWithDiagnostics HscEnv
hsc_env ModSummary
mod_summary HsParsedModule
rdr_module =
    HscEnv
-> Hsc (TcGblEnv, RenamedStuff)
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env (Hsc (TcGblEnv, RenamedStuff)
 -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage))
-> Hsc (TcGblEnv, RenamedStuff)
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
forall a b. (a -> b) -> a -> b
$ Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
True ModSummary
mod_summary (HsParsedModule -> Maybe HsParsedModule
forall a. a -> Maybe a
Just HsParsedModule
rdr_module)

-- ============================================================================
-- DO NOT EDIT - Refer to top of file
-- ============================================================================
hsc_typecheck :: Bool -- ^ Keep renamed source?
              -> ModSummary -> Maybe HsParsedModule
              -> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck :: Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
keep_rn ModSummary
mod_summary Maybe HsParsedModule
mb_rdr_module = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    let hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
        mod_name :: ModuleName
mod_name = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod
        outer_mod' :: Module
outer_mod' = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
        inner_mod :: Module
inner_mod = HomeUnit -> ModuleName -> Module
homeModuleNameInstantiation HomeUnit
home_unit ModuleName
mod_name
        src_filename :: FilePath
src_filename  = ModSummary -> FilePath
ms_hspp_file ModSummary
mod_summary
        real_loc :: RealSrcSpan
real_loc = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> TypeIndex -> TypeIndex -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
src_filename) TypeIndex
1 TypeIndex
1
        keep_rn' :: Bool
keep_rn' = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags Bool -> Bool -> Bool
|| Bool
keep_rn
    Bool -> Hsc ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
outer_mod)
    TcGblEnv
tc_result <- if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Bool -> Bool
not (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
inner_mod)
        then IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe TcGblEnv)
 -> IO (Messages GhcMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> RealSrcSpan
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature HscEnv
hsc_env Module
outer_mod' RealSrcSpan
real_loc
        else
         do HsParsedModule
hpm <- case Maybe HsParsedModule
mb_rdr_module of
                    Just HsParsedModule
hpm -> HsParsedModule -> Hsc HsParsedModule
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
hpm
                    Maybe HsParsedModule
Nothing  -> ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
            TcGblEnv
tc_result0 <- ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
mod_summary Bool
keep_rn' HsParsedModule
hpm
            if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
                then
#if MIN_VERSION_ghc(9,5,0)
                     do (ModIface
iface, ModDetails
_) <- IO (ModIface, ModDetails) -> Hsc (ModIface, ModDetails)
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, ModDetails) -> Hsc (ModIface, ModDetails))
-> IO (ModIface, ModDetails) -> Hsc (ModIface, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env Maybe CoreProgram
forall a. Maybe a
Nothing TcGblEnv
tc_result0 ModSummary
mod_summary
#else
                     do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary
#endif
                        IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe TcGblEnv)
 -> IO (Messages GhcMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
                            HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures HscEnv
hsc_env HsParsedModule
hpm TcGblEnv
tc_result0 ModIface
iface
                else TcGblEnv -> Hsc TcGblEnv
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tc_result0
    Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
rn_info <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
    (TcGblEnv,
 Maybe
   (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
    Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
    Maybe (LHsDoc GhcRn)))
-> Hsc
     (TcGblEnv,
      Maybe
        (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
         Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
         Maybe (LHsDoc GhcRn)))
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tc_result, Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
rn_info)

-- ============================================================================
-- DO NOT EDIT - Refer to top of file
-- ============================================================================
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result = do
    let rn_info :: RenamedStuff
rn_info = TcGblEnv -> RenamedStuff
getRenamedStuff TcGblEnv
tc_result

    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_rn_ast FilePath
"Renamer"
                DumpFormat
FormatHaskell (BlankSrcSpan
-> BlankEpAnnotations
-> Maybe
     (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
      Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
      Maybe (LHsDoc GhcRn))
-> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
rn_info)

    -- Create HIE files
    Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
        -- I assume this fromJust is safe because `-fwrite-hie-file`
        -- enables the option which keeps the renamed source.
        HieFile
hieFile <- ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
forall (m :: * -> *).
MonadIO m =>
ModSummary -> TcGblEnv -> RenamedSource -> m HieFile
mkHieFile ModSummary
mod_summary TcGblEnv
tc_result (Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
-> (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
    Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
    Maybe (LHsDoc GhcRn))
forall a. HasCallStack => Maybe a -> a
fromJust Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
rn_info)
        let out_file :: FilePath
out_file = ModLocation -> FilePath
ml_hie_file (ModLocation -> FilePath) -> ModLocation -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
mod_summary
        IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> HieFile -> IO ()
writeHieFile FilePath
out_file HieFile
hieFile
        IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_hie FilePath
"HIE AST" DumpFormat
FormatHaskell (HieASTs TypeIndex -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HieASTs TypeIndex -> SDoc) -> HieASTs TypeIndex -> SDoc
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs TypeIndex
hie_asts HieFile
hieFile)

        -- Validate HIE files
        Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ValidateHie DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
            HscEnv
hs_env <- (HscEnv -> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv
forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc ((HscEnv
  -> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
 -> Hsc HscEnv)
-> (HscEnv
    -> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
e Messages GhcMessage
w -> (HscEnv, Messages GhcMessage) -> IO (HscEnv, Messages GhcMessage)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, Messages GhcMessage
w)
            IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
              -- Validate Scopes
              case Module -> Map HiePath (HieAST TypeIndex) -> [SDoc]
forall a. Module -> Map HiePath (HieAST a) -> [SDoc]
validateScopes (HieFile -> Module
hie_module HieFile
hieFile) (Map HiePath (HieAST TypeIndex) -> [SDoc])
-> Map HiePath (HieAST TypeIndex) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts (HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex))
-> HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs TypeIndex
hie_asts HieFile
hieFile of
                  [] -> Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Got valid scopes"
                  [SDoc]
xs -> do
                    Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Got invalid scopes"
                    (SDoc -> IO ()) -> [SDoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> SDoc -> IO ()
putMsg Logger
logger) [SDoc]
xs
              -- Roundtrip testing
              HieFileResult
file' <- NameCache -> FilePath -> IO HieFileResult
readHieFile (HscEnv -> NameCache
hsc_NC HscEnv
hs_env) FilePath
out_file
              case Diff HieFile
diffFile HieFile
hieFile (HieFileResult -> HieFile
hie_file_result HieFileResult
file') of
                [] ->
                  Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Got no roundtrip errors"
                [SDoc]
xs -> do
                  Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Got roundtrip errors"
                  let logger' :: Logger
logger' = Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags Logger
logger (DumpFlag -> LogFlags -> LogFlags
log_set_dopt DumpFlag
Opt_D_ppr_debug)
                  (SDoc -> IO ()) -> [SDoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> SDoc -> IO ()
putMsg Logger
logger') [SDoc]
xs
    Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
-> Hsc
     (Maybe
        (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
         Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
         Maybe (LHsDoc GhcRn)))
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
rn_info

-- ============================================================================
-- DO NOT EDIT - Refer to top of file
-- ============================================================================
#if MIN_VERSION_ghc(9,5,0)
hscSimpleIface :: HscEnv
               -> Maybe CoreProgram
               -> TcGblEnv
               -> ModSummary
               -> IO (ModIface, ModDetails)
hscSimpleIface :: HscEnv
-> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env Maybe CoreProgram
mb_core_program TcGblEnv
tc_result ModSummary
summary
    = HscEnv -> Hsc (ModIface, ModDetails) -> IO (ModIface, ModDetails)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (ModIface, ModDetails) -> IO (ModIface, ModDetails))
-> Hsc (ModIface, ModDetails) -> IO (ModIface, ModDetails)
forall a b. (a -> b) -> a -> b
$ Maybe CoreProgram
-> TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails)
hscSimpleIface' Maybe CoreProgram
mb_core_program TcGblEnv
tc_result ModSummary
summary
#else
hscSimpleIface :: HscEnv
               -> TcGblEnv
               -> ModSummary
               -> IO (ModIface, ModDetails)
hscSimpleIface hsc_env tc_result summary
    = runHsc hsc_env $ hscSimpleIface' tc_result summary
#endif

#endif