-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP        #-}
{-# LANGUAGE GADTs      #-}
{-# LANGUAGE RankNTypes #-}

-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.
--   Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
module Development.IDE.Core.Compile
  ( TcModuleResult(..)
  , RunSimplifier(..)
  , compileModule
  , parseModule
  , typecheckModule
  , computePackageDeps
  , addRelativeImport
  , mkHiFileResultCompile
  , mkHiFileResultNoCompile
  , generateObjectCode
  , generateByteCode
  , generateHieAsts
  , writeAndIndexHieFile
  , indexHieFile
  , writeHiFile
  , getModSummaryFromImports
  , loadHieFile
  , loadInterface
  , RecompilationInfo(..)
  , loadModulesHome
  , getDocsBatch
  , lookupName
  , mergeEnvs
  , ml_core_file
  , coreFileToLinkable
  , TypecheckHelpers(..)
  , sourceTypecheck
  , sourceParser
  , shareUsages
  ) where

import           Prelude                           hiding (mod)
import           Control.Monad.IO.Class
import           Control.Concurrent.Extra
import           Control.Concurrent.STM.Stats      hiding (orElse)
import           Control.DeepSeq                   (NFData (..), force,
                                                    rnf)
import           Control.Exception                 (evaluate)
import           Control.Exception.Safe
import           Control.Lens                      hiding (List, (<.>), pre)
import           Control.Monad.Except
import           Control.Monad.Extra
import           Control.Monad.Trans.Except
import qualified Control.Monad.Trans.State.Strict  as S
import           Data.Aeson                        (toJSON)
import           Data.Bifunctor                    (first, second)
import           Data.Binary
import qualified Data.ByteString                   as BS
import           Data.Coerce
import qualified Data.DList                        as DL
import           Data.Functor
import           Data.Generics.Aliases
import           Data.Generics.Schemes
import qualified Data.HashMap.Strict               as HashMap
import           Data.IntMap                       (IntMap)
import           Data.IORef
import           Data.List.Extra
import qualified Data.Map.Strict                   as Map
import           Data.Proxy                        (Proxy(Proxy))
import           Data.Maybe
import qualified Data.Text                         as T
import           Data.Time                         (UTCTime (..))
import           Data.Tuple.Extra                  (dupe)
import           Data.Unique                       as Unique
import           Debug.Trace
import           Development.IDE.Core.FileStore    (resetInterfaceStore)
import           Development.IDE.Core.Preprocessor
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake
import           Development.IDE.Core.Tracing      (withTrace)
import           Development.IDE.GHC.Compat        hiding (loadInterface,
                                                    parseHeader, parseModule,
                                                    tcRnModule, writeHieFile)
import qualified Development.IDE.GHC.Compat        as Compat
import qualified Development.IDE.GHC.Compat        as GHC
import qualified Development.IDE.GHC.Compat.Util   as Util
import           Development.IDE.GHC.CoreFile
import           Development.IDE.GHC.Error
import           Development.IDE.GHC.Orphans       ()
import           Development.IDE.GHC.Util
import           Development.IDE.GHC.Warnings
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import           GHC                               (ForeignHValue,
                                                    GetDocsFailure (..),
                                                    parsedSource)
import qualified GHC.LanguageExtensions            as LangExt
import           GHC.Serialized
import           HieDb                             hiding (withHieDb)
import qualified Language.LSP.Server               as LSP
import           Language.LSP.Protocol.Types                (DiagnosticTag (..))
import qualified Language.LSP.Protocol.Types                as LSP
import qualified Language.LSP.Protocol.Message            as LSP
import           System.Directory
import           System.FilePath
import           System.IO.Extra                   (fixIO, newTempFileWithin)

-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]

import           GHC.Tc.Gen.Splice



import qualified GHC                               as G

#if !MIN_VERSION_ghc(9,3,0)
import           GHC                               (ModuleGraph)
#endif

import           GHC.Types.ForeignStubs
import           GHC.Types.HpcInfo
import           GHC.Types.TypeEnv

#if !MIN_VERSION_ghc(9,3,0)
import           Data.Map                          (Map)
import           GHC                               (GhcException (..))
import           Unsafe.Coerce
#endif

#if MIN_VERSION_ghc(9,3,0)
import qualified Data.Set                          as Set
#endif

#if MIN_VERSION_ghc(9,5,0)
import           GHC.Driver.Config.CoreToStg.Prep
import           GHC.Core.Lint.Interactive
#endif

#if MIN_VERSION_ghc(9,7,0)
import           Data.Foldable                     (toList)
import           GHC.Unit.Module.Warnings
#else
import           Development.IDE.Core.FileStore    (shareFilePath)
#endif

--Simple constants to make sure the source is consistently named
sourceTypecheck :: T.Text
sourceTypecheck :: Text
sourceTypecheck = Text
"typecheck"
sourceParser :: T.Text
sourceParser :: Text
sourceParser = Text
"parser"

-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
parseModule
    :: IdeOptions
    -> HscEnv
    -> FilePath
    -> ModSummary
    -> IO (IdeResult ParsedModule)
parseModule :: IdeOptions
-> HscEnv -> [Char] -> ModSummary -> IO (IdeResult ParsedModule)
parseModule IdeOptions{Bool
Int
[Char]
[[Char]]
[Text]
Maybe [Char]
IO Bool
IO CheckParents
ShakeOptions
Action IdeGhcSession
IdePkgLocationOptions
ProgressReportingStyle
IdeTesting
IdeDefer
IdeReportProgress
OptHaddockParse
ParsedSource -> IdePreprocessedSource
Config -> DynFlagsModifications
forall a. Typeable a => a -> Bool
optVerifyCoreFile :: IdeOptions -> Bool
optRunSubset :: IdeOptions -> Bool
optProgressStyle :: IdeOptions -> ProgressReportingStyle
optSkipProgress :: IdeOptions -> forall a. Typeable a => a -> Bool
optShakeOptions :: IdeOptions -> ShakeOptions
optModifyDynFlags :: IdeOptions -> Config -> DynFlagsModifications
optHaddockParse :: IdeOptions -> OptHaddockParse
optCheckParents :: IdeOptions -> IO CheckParents
optCheckProject :: IdeOptions -> IO Bool
optDefer :: IdeOptions -> IdeDefer
optKeywords :: IdeOptions -> [Text]
optNewColonConvention :: IdeOptions -> Bool
optLanguageSyntax :: IdeOptions -> [Char]
optMaxDirtyAge :: IdeOptions -> Int
optReportProgress :: IdeOptions -> IdeReportProgress
optTesting :: IdeOptions -> IdeTesting
optShakeProfiling :: IdeOptions -> Maybe [Char]
optExtensions :: IdeOptions -> [[Char]]
optPkgLocationOpts :: IdeOptions -> IdePkgLocationOptions
optGhcSession :: IdeOptions -> Action IdeGhcSession
optPreprocessor :: IdeOptions -> ParsedSource -> IdePreprocessedSource
optVerifyCoreFile :: Bool
optRunSubset :: Bool
optProgressStyle :: ProgressReportingStyle
optSkipProgress :: forall a. Typeable a => a -> Bool
optShakeOptions :: ShakeOptions
optModifyDynFlags :: Config -> DynFlagsModifications
optHaddockParse :: OptHaddockParse
optCheckParents :: IO CheckParents
optCheckProject :: IO Bool
optDefer :: IdeDefer
optKeywords :: [Text]
optNewColonConvention :: Bool
optLanguageSyntax :: [Char]
optMaxDirtyAge :: Int
optReportProgress :: IdeReportProgress
optTesting :: IdeTesting
optShakeProfiling :: Maybe [Char]
optExtensions :: [[Char]]
optPkgLocationOpts :: IdePkgLocationOptions
optGhcSession :: Action IdeGhcSession
optPreprocessor :: ParsedSource -> IdePreprocessedSource
..} HscEnv
env [Char]
filename ModSummary
ms =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, forall a. Maybe a
Nothing) forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
        ([FileDiagnostic]
diag, ParsedModule
modu) <- HscEnv
-> (ParsedSource -> IdePreprocessedSource)
-> [Char]
-> ModSummary
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
parseFileContents HscEnv
env ParsedSource -> IdePreprocessedSource
optPreprocessor [Char]
filename ModSummary
ms
        forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
diag, forall a. a -> Maybe a
Just ParsedModule
modu)


-- | Given a package identifier, what packages does it depend on
computePackageDeps
    :: HscEnv
    -> Unit
    -> IO (Either [FileDiagnostic] [UnitId])
computePackageDeps :: HscEnv -> Unit -> IO (Either [FileDiagnostic] [UnitId])
computePackageDeps HscEnv
env Unit
pkg = do
    case HscEnv -> Unit -> Maybe UnitInfo
lookupUnit HscEnv
env Unit
pkg of
        Maybe UnitInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText ([Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
noFilePath) forall a b. (a -> b) -> a -> b
$
            [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"unknown package: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Unit
pkg]
        Just UnitInfo
pkgInfo -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends UnitInfo
pkgInfo

newtype TypecheckHelpers
  = TypecheckHelpers
  { TypecheckHelpers -> [NormalizedFilePath] -> IO [LinkableResult]
getLinkables       :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files
  }

typecheckModule :: IdeDefer
                -> HscEnv
                -> TypecheckHelpers
                -> ParsedModule
                -> IO (IdeResult TcModuleResult)
typecheckModule :: IdeDefer
-> HscEnv
-> TypecheckHelpers
-> ParsedModule
-> IO (IdeResult TcModuleResult)
typecheckModule (IdeDefer Bool
defer) HscEnv
hsc TypecheckHelpers
tc_helpers ParsedModule
pm = do
        let modSummary :: ModSummary
modSummary = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pm
            dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSummary
        Either [FileDiagnostic] (ModSummary, HscEnv)
initialized <- forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc) Text
"typecheck (initialize plugins)"
                                      (HscEnv -> ModSummary -> IO (ModSummary, HscEnv)
initPlugins HscEnv
hsc ModSummary
modSummary)
        case Either [FileDiagnostic] (ModSummary, HscEnv)
initialized of
          Left [FileDiagnostic]
errs -> forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
errs, forall a. Maybe a
Nothing)
          Right (ModSummary
modSummary', HscEnv
hscEnv) -> do
            ([(WarnReason, FileDiagnostic)]
warnings, Either [FileDiagnostic] TcModuleResult
etcm) <- forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
sourceTypecheck forall a b. (a -> b) -> a -> b
$ \HscEnv -> HscEnv
tweak ->
                let
                  session :: HscEnv
session = HscEnv -> HscEnv
tweak (DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
hscEnv)
                   -- TODO: maybe settings ms_hspp_opts is unnecessary?
                  mod_summary'' :: ModSummary
mod_summary'' = ModSummary
modSummary' { ms_hspp_opts :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
session}
                in
                  forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv) Text
sourceTypecheck forall a b. (a -> b) -> a -> b
$ do
                    HscEnv -> TypecheckHelpers -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
session TypecheckHelpers
tc_helpers forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedModule
demoteIfDefer ParsedModule
pm{pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
mod_summary''}
            let errorPipeline :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
errorPipeline = (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
hideDiag DynFlags
dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
tagDiag
                diags :: [(Bool, FileDiagnostic)]
diags = forall a b. (a -> b) -> [a] -> [b]
map (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
errorPipeline [(WarnReason, FileDiagnostic)]
warnings
                deferredError :: Bool
deferredError = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> a
fst [(Bool, FileDiagnostic)]
diags
            case Either [FileDiagnostic] TcModuleResult
etcm of
              Left [FileDiagnostic]
errs -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, FileDiagnostic)]
diags forall a. [a] -> [a] -> [a]
++ [FileDiagnostic]
errs, forall a. Maybe a
Nothing)
              Right TcModuleResult
tcm -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, FileDiagnostic)]
diags, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TcModuleResult
tcm{tmrDeferredError :: Bool
tmrDeferredError = Bool
deferredError})
    where
        demoteIfDefer :: ParsedModule -> ParsedModule
demoteIfDefer = if Bool
defer then ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings else forall a. a -> a
id

-- | Install hooks to capture the splices as well as the runtime module dependencies
captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString)
captureSplicesAndDeps :: forall a.
TypecheckHelpers
-> HscEnv
-> (HscEnv -> IO a)
-> IO (a, Splices, ModuleEnv ByteString)
captureSplicesAndDeps TypecheckHelpers{[NormalizedFilePath] -> IO [LinkableResult]
getLinkables :: [NormalizedFilePath] -> IO [LinkableResult]
getLinkables :: TypecheckHelpers -> [NormalizedFilePath] -> IO [LinkableResult]
..} HscEnv
env HscEnv -> IO a
k = do
  IORef Splices
splice_ref <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
  IORef (ModuleEnv ByteString)
dep_ref <- forall a. a -> IO (IORef a)
newIORef forall a. ModuleEnv a
emptyModuleEnv
  a
res <- HscEnv -> IO a
k (Hooks -> HscEnv -> HscEnv
hscSetHooks (IORef Splices -> Hooks -> Hooks
addSpliceHook IORef Splices
splice_ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (ModuleEnv ByteString) -> Hooks -> Hooks
addLinkableDepHook IORef (ModuleEnv ByteString)
dep_ref forall a b. (a -> b) -> a -> b
$ HscEnv -> Hooks
hsc_hooks HscEnv
env) HscEnv
env)
  Splices
splices <- forall a. IORef a -> IO a
readIORef IORef Splices
splice_ref
  ModuleEnv ByteString
needed_mods <- forall a. IORef a -> IO a
readIORef IORef (ModuleEnv ByteString)
dep_ref
  forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Splices
splices, ModuleEnv ByteString
needed_mods)
  where
    addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks
    addLinkableDepHook :: IORef (ModuleEnv ByteString) -> Hooks -> Hooks
addLinkableDepHook IORef (ModuleEnv ByteString)
var Hooks
h = Hooks
h { hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook = forall a. a -> Maybe a
Just (IORef (ModuleEnv ByteString)
-> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
compile_bco_hook IORef (ModuleEnv ByteString)
var) }

    -- We want to record exactly which linkables/modules the typechecker needed at runtime
    -- This is useful for recompilation checking.
    -- See Note [Recompilation avoidance in the presence of TH]
    --
    -- From hscCompileCoreExpr' in GHC
    -- To update, copy hscCompileCoreExpr' (the implementation of
    -- hscCompileCoreExprHook) verbatim, and add code to extract all the free
    -- names in the compiled bytecode, recording the modules that those names
    -- come from in the IORef,, as these are the modules on whose implementation
    -- we depend.
    compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr
#if MIN_VERSION_ghc(9,3,0)
                     -> IO (ForeignHValue, [Linkable], PkgsLoaded)
#else
                     -> IO ForeignHValue
#endif
    compile_bco_hook :: IORef (ModuleEnv ByteString)
-> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
compile_bco_hook IORef (ModuleEnv ByteString)
var HscEnv
hsc_env SrcSpan
srcspan CoreExpr
ds_expr
      = do { let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

             {- Simplify it -}
           ; CoreExpr
simpl_expr <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
simplifyExpr DynFlags
dflags HscEnv
hsc_env CoreExpr
ds_expr

             {- Tidy it (temporary, until coreSat does cloning) -}
           ; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr

             {- Prepare for codegen -}
           ; CoreExpr
prepd_expr <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr DynFlags
dflags HscEnv
hsc_env CoreExpr
tidy_expr

             {- Lint if necessary -}
           ; SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr SDoc
"hscCompileExpr" HscEnv
hsc_env CoreExpr
prepd_expr


           ; let iNTERACTIVELoc :: ModLocation
iNTERACTIVELoc = G.ModLocation{ ml_hs_file :: Maybe [Char]
ml_hs_file   = forall a. Maybe a
Nothing,
                                        ml_hi_file :: [Char]
ml_hi_file   = forall a. [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hi_file",
                                        ml_obj_file :: [Char]
ml_obj_file  = forall a. [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_obj_file",
#if MIN_VERSION_ghc(9,3,0)
                                        ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file",
                                        ml_dyn_hi_file  = panic "hscCompileCoreExpr':ml_dyn_hi_file",
#endif
                                        ml_hie_file :: [Char]
ml_hie_file  = forall a. [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hie_file"
                                        }
           ; let ictxt :: InteractiveContext
ictxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env

           ; (Id
binding_id, [StgTopBinding]
stg_expr, InfoTableProvMap
_, CollectedCCs
_) <-
               Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreExpr
-> IO (Id, [StgTopBinding], InfoTableProvMap, CollectedCCs)
myCoreToStgExpr (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
                               (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                               InteractiveContext
ictxt
#if MIN_VERSION_ghc(9,3,0)
                               True -- for bytecode
#endif
                               (InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
                               ModLocation
iNTERACTIVELoc
                               CoreExpr
prepd_expr

             {- Convert to BCOs -}
           ; CompiledByteCode
bcos <- HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env
                       (InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
                       [StgTopBinding]
stg_expr
                       [] forall a. Maybe a
Nothing

            -- Exclude wired-in names because we may not have read
            -- their interface files, so getLinkDeps will fail
            -- All wired-in names are in the base package, which we link
            -- by default, so we can safely ignore them here.

            -- Find the linkables for the modules we need
           ; let needed_mods :: UniqSet ModuleName
needed_mods = forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [
#if MIN_VERSION_ghc(9,3,0)
                                           mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids
#else
                                           forall unit. GenModule unit -> ModuleName
moduleName Module
mod -- On <= 9.2, just the name is enough because all unit ids will be the same
#endif

                                         | Name
n <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. UniqDSet a -> [a]
uniqDSetToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnlinkedBCO -> UniqDSet Name
bcoFreeNames) forall a b. (a -> b) -> a -> b
$ CompiledByteCode -> [UnlinkedBCO]
bc_bcos CompiledByteCode
bcos
                                         , Just Module
mod <- [Name -> Maybe Module
nameModule_maybe Name
n] -- Names from other modules
                                         , Bool -> Bool
not (Name -> Bool
isWiredInName Name
n) -- Exclude wired-in names
                                         , Module -> UnitId
moduleUnitId Module
mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
home_unit_ids -- Only care about stuff from the home package set
                                         ]
                 home_unit_ids :: [UnitId]
home_unit_ids =
#if MIN_VERSION_ghc(9,3,0)
                    map fst (hugElts $ hsc_HUG hsc_env)
#else
                    [DynFlags -> UnitId
homeUnitId_ DynFlags
dflags]
#endif
                 mods_transitive :: UniqSet ModuleName
mods_transitive = HscEnv -> UniqSet ModuleName -> UniqSet ModuleName
getTransitiveMods HscEnv
hsc_env UniqSet ModuleName
needed_mods

                 -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same
                 mods_transitive_list :: [InstalledModule]
mods_transitive_list =
#if MIN_VERSION_ghc(9,3,0)
                                         mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive
#else
                                        -- Non det OK as we will put it into maps later anyway
                                         forall a b. (a -> b) -> [a] -> [b]
map (forall unit. unit -> ModuleName -> GenModule unit
Compat.installedModule (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)) forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
mods_transitive
#endif

#if MIN_VERSION_ghc(9,3,0)
           ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env)
#else
           ; FinderCache
moduleLocs <- forall a. IORef a -> IO a
readIORef (HscEnv -> IORef FinderCache
hsc_FC HscEnv
hsc_env)
#endif
           ; [LinkableResult]
lbs <- [NormalizedFilePath] -> IO [LinkableResult]
getLinkables [[Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
file
                                 | InstalledModule
installedMod <- [InstalledModule]
mods_transitive_list
                                 , let ifr :: InstalledFindResult
ifr = forall a. (?callStack::CallStack) => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. InstalledModuleEnv a -> InstalledModule -> Maybe a
lookupInstalledModuleEnv FinderCache
moduleLocs InstalledModule
installedMod
                                       file :: [Char]
file = case InstalledFindResult
ifr of
                                         InstalledFound ModLocation
loc InstalledModule
_ ->
                                           forall a. (?callStack::CallStack) => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ ModLocation -> Maybe [Char]
ml_hs_file ModLocation
loc
                                         InstalledFindResult
_ -> forall a. [Char] -> a
panic [Char]
"hscCompileCoreExprHook: module not found"
                                 ]
           ; let hsc_env' :: HscEnv
hsc_env' = [HomeModInfo] -> HscEnv -> HscEnv
loadModulesHome (forall a b. (a -> b) -> [a] -> [b]
map LinkableResult -> HomeModInfo
linkableHomeMod [LinkableResult]
lbs) HscEnv
hsc_env

#if MIN_VERSION_ghc(9,3,0)
             {- load it -}
           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos
           ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs)
#else
             {- load it -}
           ; [(Name, ForeignHValue)]
fv_hvs <- Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO [(Name, ForeignHValue)]
loadDecls (HscEnv -> Interp
hscInterp HscEnv
hsc_env') HscEnv
hsc_env' SrcSpan
srcspan CompiledByteCode
bcos
           ; let hval :: ForeignHValue
hval = (forall a. (?callStack::CallStack) => [Char] -> Maybe a -> a
expectJust [Char]
"hscCompileCoreExpr'" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Id -> Name
idName Id
binding_id) [(Name, ForeignHValue)]
fv_hvs)
#endif

           ; forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ModuleEnv ByteString)
var (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. ModuleEnv a -> [(Module, a)] -> ModuleEnv a
extendModuleEnvList [(forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface
hm_iface HomeModInfo
hm, LinkableResult -> ByteString
linkableHash LinkableResult
lb) | LinkableResult
lb <- [LinkableResult]
lbs, let hm :: HomeModInfo
hm = LinkableResult -> HomeModInfo
linkableHomeMod LinkableResult
lb])
           ; forall (m :: * -> *) a. Monad m => a -> m a
return ForeignHValue
hval }

#if MIN_VERSION_ghc(9,3,0)
    -- TODO: support backpack
    nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule
    -- We shouldn't get boot files here, but to be safe, never map them to an installed module
    -- because boot files don't have linkables we can load, and we will fail if we try to look
    -- for them
    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = Nothing
    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB moduleName _) uid)) = Just $ mkModule uid moduleName
    nodeKeyToInstalledModule _ = Nothing
    moduleToNodeKey :: Module -> NodeKey
    moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)
#endif

    -- Compute the transitive set of linkables required
    getTransitiveMods :: HscEnv -> UniqSet ModuleName -> UniqSet ModuleName
getTransitiveMods HscEnv
hsc_env UniqSet ModuleName
needed_mods
#if MIN_VERSION_ghc(9,3,0)
      = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods
                                                              , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))]
                                                              ])
      where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after
#else
      = UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
go forall a. UniqSet a
emptyUniqSet UniqSet ModuleName
needed_mods
      where
        hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
        go :: UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
go UniqSet ModuleName
seen UniqSet ModuleName
new
          | forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet ModuleName
new = UniqSet ModuleName
seen
          | Bool
otherwise = UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
go UniqSet ModuleName
seen' UniqSet ModuleName
new'
            where
              seen' :: UniqSet ModuleName
seen' = UniqSet ModuleName
seen forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` UniqSet ModuleName
new
              new' :: UniqSet ModuleName
new'  = UniqSet ModuleName
new_deps forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet ModuleName
seen'
              new_deps :: UniqSet ModuleName
new_deps = forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets [ forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet forall a b. (a -> b) -> a -> b
$ ModIface -> [ModuleName]
getDependentMods forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info
                                           | HomeModInfo
mod_info <- forall key elt. UniqDFM key elt -> [elt]
eltsUDFM forall a b. (a -> b) -> a -> b
$ forall key elt1 elt2.
UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1
udfmIntersectUFM HomePackageTable
hpt (forall a. UniqSet a -> UniqFM a a
getUniqSet UniqSet ModuleName
new)]
#endif

    -- | Add a Hook to the DynFlags which captures and returns the
    -- typechecked splices before they are run. This information
    -- is used for hover.
    addSpliceHook :: IORef Splices -> Hooks -> Hooks
    addSpliceHook :: IORef Splices -> Hooks -> Hooks
addSpliceHook IORef Splices
var Hooks
h = Hooks
h { runMetaHook :: Maybe (MetaHook (IOEnv (Env TcGblEnv TcLclEnv)))
runMetaHook = forall a. a -> Maybe a
Just (Maybe (MetaHook (IOEnv (Env TcGblEnv TcLclEnv)))
-> IORef Splices -> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
splice_hook (Hooks -> Maybe (MetaHook (IOEnv (Env TcGblEnv TcLclEnv)))
runMetaHook Hooks
h) IORef Splices
var) }

    splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM
    splice_hook :: Maybe (MetaHook (IOEnv (Env TcGblEnv TcLclEnv)))
-> IORef Splices -> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
splice_hook (forall a. a -> Maybe a -> a
fromMaybe MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
defaultRunMeta -> MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcM MetaResult
hook) IORef Splices
var MetaRequest
metaReq LHsExpr GhcTc
e = case MetaRequest
metaReq of
        (MetaE LHsExpr GhcPs -> MetaResult
f) -> do
            GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr' <- forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)
metaRequestE MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcM MetaResult
hook LHsExpr GhcTc
e
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var forall a b. (a -> b) -> a -> b
$ Lens' Splices [(LHsExpr GhcTc, LHsExpr GhcPs)]
exprSplicesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((LHsExpr GhcTc
e, GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr') forall a. a -> [a] -> [a]
:)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> MetaResult
f GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr'
        (MetaP LPat GhcPs -> MetaResult
f) -> do
            GenLocated SrcSpanAnnA (Pat GhcPs)
pat' <- forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)
metaRequestP MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcM MetaResult
hook LHsExpr GhcTc
e
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var forall a b. (a -> b) -> a -> b
$ Lens' Splices [(LHsExpr GhcTc, LPat GhcPs)]
patSplicesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((LHsExpr GhcTc
e, GenLocated SrcSpanAnnA (Pat GhcPs)
pat') forall a. a -> [a] -> [a]
:)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> MetaResult
f GenLocated SrcSpanAnnA (Pat GhcPs)
pat'
        (MetaT LHsType GhcPs -> MetaResult
f) -> do
            GenLocated SrcSpanAnnA (HsType GhcPs)
type' <- forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)
metaRequestT MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcM MetaResult
hook LHsExpr GhcTc
e
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var forall a b. (a -> b) -> a -> b
$ Lens' Splices [(LHsExpr GhcTc, LHsType GhcPs)]
typeSplicesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((LHsExpr GhcTc
e, GenLocated SrcSpanAnnA (HsType GhcPs)
type') forall a. a -> [a] -> [a]
:)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> MetaResult
f GenLocated SrcSpanAnnA (HsType GhcPs)
type'
        (MetaD [LHsDecl GhcPs] -> MetaResult
f) -> do
            [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decl' <- forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]
metaRequestD MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcM MetaResult
hook LHsExpr GhcTc
e
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var forall a b. (a -> b) -> a -> b
$ Lens' Splices [(LHsExpr GhcTc, [LHsDecl GhcPs])]
declSplicesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((LHsExpr GhcTc
e, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decl') forall a. a -> [a] -> [a]
:)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [LHsDecl GhcPs] -> MetaResult
f [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decl'
        (MetaAW Serialized -> MetaResult
f) -> do
            Serialized
aw' <- forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f Serialized
metaRequestAW MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcM MetaResult
hook LHsExpr GhcTc
e
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var forall a b. (a -> b) -> a -> b
$ Lens' Splices [(LHsExpr GhcTc, Serialized)]
awSplicesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((LHsExpr GhcTc
e, Serialized
aw') forall a. a -> [a] -> [a]
:)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Serialized -> MetaResult
f Serialized
aw'


tcRnModule
  :: HscEnv
  -> TypecheckHelpers -- ^ Program linkables not to unload
  -> ParsedModule
  -> IO TcModuleResult
tcRnModule :: HscEnv -> TypecheckHelpers -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
hsc_env TypecheckHelpers
tc_helpers ParsedModule
pmod = do
  let ms :: ModSummary
ms = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pmod
      hsc_env_tmp :: HscEnv
hsc_env_tmp = DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
hsc_env

  ((TcGblEnv
tc_gbl_env', Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe LHsDocString)
mrn_info), Splices
splices, ModuleEnv ByteString
mod_env)
      <- forall a.
TypecheckHelpers
-> HscEnv
-> (HscEnv -> IO a)
-> IO (a, Splices, ModuleEnv ByteString)
captureSplicesAndDeps TypecheckHelpers
tc_helpers HscEnv
hsc_env_tmp forall a b. (a -> b) -> a -> b
$ \HscEnv
hscEnvTmp ->
             do  HscEnv
-> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename HscEnv
hscEnvTmp ModSummary
ms forall a b. (a -> b) -> a -> b
$
                          HsParsedModule { hpm_module :: ParsedSource
hpm_module = forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
                                           hpm_src_files :: [[Char]]
hpm_src_files = ParsedModule -> [[Char]]
pm_extra_src_files ParsedModule
pmod,
                                           hpm_annotations :: ()
hpm_annotations = ParsedModule -> ()
pm_annotations ParsedModule
pmod }
  let rn_info :: (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
 Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
 Maybe LHsDocString)
rn_info = case Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe LHsDocString)
mrn_info of
        Just (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
 Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
 Maybe LHsDocString)
x  -> (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
 Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
 Maybe LHsDocString)
x
        Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe LHsDocString)
Nothing -> forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"no renamed info tcRnModule"

      -- Serialize mod_env so we can read it from the interface
      mod_env_anns :: [Annotation]
mod_env_anns = forall a b. (a -> b) -> [a] -> [b]
map (\(Module
mod, ByteString
hash) -> CoreAnnTarget -> Serialized -> Annotation
Annotation (forall name. Module -> AnnTarget name
ModuleTarget Module
mod) forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized ByteString -> [Word8]
BS.unpack ByteString
hash)
                         (forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ModuleEnv ByteString
mod_env)
      tc_gbl_env :: TcGblEnv
tc_gbl_env = TcGblEnv
tc_gbl_env' { tcg_ann_env :: AnnEnv
tcg_ann_env = AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
tc_gbl_env') [Annotation]
mod_env_anns }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedModule
-> RenamedSource
-> TcGblEnv
-> Splices
-> Bool
-> ModuleEnv ByteString
-> TcModuleResult
TcModuleResult ParsedModule
pmod (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
 Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
 Maybe LHsDocString)
rn_info TcGblEnv
tc_gbl_env Splices
splices Bool
False ModuleEnv ByteString
mod_env)


-- Note [Clearing mi_globals after generating an iface]
-- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode
-- interpreter.
-- However, this field is expensive in terms of heap usage, and we don't use it in HLS
-- anywhere. So we zero it out.
-- The field is not serialized or deserialised from disk, so we don't need to remove it
-- while reading an iface from disk, only if we just generated an iface in memory
--



-- | See https://github.com/haskell/haskell-language-server/issues/3450
-- GHC's recompilation avoidance in the presense of TH is less precise than
-- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information
-- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH]
filterUsages :: [Usage] -> [Usage]
#if MIN_VERSION_ghc(9,3,0)
filterUsages = filter $ \case UsageHomeModuleInterface{} -> False
                              _ -> True
#else
filterUsages :: [Usage] -> [Usage]
filterUsages = forall a. a -> a
id
#endif

-- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744
-- Important to do this immediately after reading the unit before
-- anything else has a chance to read `mi_usages`
shareUsages :: ModIface -> ModIface
shareUsages :: ModIface -> ModIface
shareUsages ModIface
iface
  = ModIface
iface
-- Fixed upstream in GHC 9.8
#if !MIN_VERSION_ghc(9,7,0)
      {mi_usages :: [Usage]
mi_usages = [Usage]
usages}
  where usages :: [Usage]
usages = forall a b. (a -> b) -> [a] -> [b]
map Usage -> Usage
go (forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages ModIface
iface)
        go :: Usage -> Usage
go usg :: Usage
usg@UsageFile{} = Usage
usg {usg_file_path :: [Char]
usg_file_path = [Char]
fp}
          where !fp :: [Char]
fp = [Char] -> [Char]
shareFilePath (Usage -> [Char]
usg_file_path Usage
usg)
        go Usage
usg = Usage
usg
#endif


mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
mkHiFileResultNoCompile HscEnv
session TcModuleResult
tcm = do
  let hsc_env_tmp :: HscEnv
hsc_env_tmp = DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
session
      ms :: ModSummary
ms = ParsedModule -> ModSummary
pm_mod_summary forall a b. (a -> b) -> a -> b
$ TcModuleResult -> ParsedModule
tmrParsed TcModuleResult
tcm
      tcGblEnv :: TcGblEnv
tcGblEnv = TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tcm
  ModDetails
details <- HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails HscEnv
hsc_env_tmp TcGblEnv
tcGblEnv
  SafeHaskellMode
sf <- DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) TcGblEnv
tcGblEnv
  ModIface
iface' <- forall {p}.
HscEnv
-> SafeHaskellMode -> ModDetails -> p -> TcGblEnv -> IO ModIface
mkIfaceTc HscEnv
hsc_env_tmp SafeHaskellMode
sf ModDetails
details ModSummary
ms
#if MIN_VERSION_ghc(9,5,0)
                      Nothing
#endif
                      TcGblEnv
tcGblEnv
  let iface :: ModIface
iface = ModIface
iface' { mi_globals :: Maybe GlobalRdrEnv
mi_globals = forall a. Maybe a
Nothing, mi_usages :: [Usage]
mi_usages = [Usage] -> [Usage]
filterUsages (forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages ModIface
iface') } -- See Note [Clearing mi_globals after generating an iface]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! ModSummary
-> ModIface
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface
iface ModDetails
details (TcModuleResult -> ModuleEnv ByteString
tmrRuntimeModules TcModuleResult
tcm) forall a. Maybe a
Nothing

mkHiFileResultCompile
    :: ShakeExtras
    -> HscEnv
    -> TcModuleResult
    -> ModGuts
    -> IO (IdeResult HiFileResult)
mkHiFileResultCompile :: ShakeExtras
-> HscEnv
-> TcModuleResult
-> ModGuts
-> IO (IdeResult HiFileResult)
mkHiFileResultCompile ShakeExtras
se HscEnv
session' TcModuleResult
tcm ModGuts
simplified_guts = IO (IdeResult HiFileResult) -> IO (IdeResult HiFileResult)
catchErrs forall a b. (a -> b) -> a -> b
$ do
  let session :: HscEnv
session = DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
session'
      ms :: ModSummary
ms = ParsedModule -> ModSummary
pm_mod_summary forall a b. (a -> b) -> a -> b
$ TcModuleResult -> ParsedModule
tmrParsed TcModuleResult
tcm

  (ModDetails
details, CgGuts
guts) <- do
        -- write core file
        -- give variables unique OccNames
        HscEnv
tidy_opts <- HscEnv -> IO HscEnv
initTidyOpts HscEnv
session
        (CgGuts
guts, ModDetails
details) <- HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
tidy_opts ModGuts
simplified_guts
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModDetails
details, CgGuts
guts)

  let !partial_iface :: PartialModIface
partial_iface = forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ HscEnv -> ModDetails -> ModGuts -> PartialModIface
mkPartialIface HscEnv
session
#if MIN_VERSION_ghc(9,5,0)
                                              (cg_binds guts)
#endif
                                              ModDetails
details
#if MIN_VERSION_ghc(9,3,0)
                                              ms
#endif
                                              ModGuts
simplified_guts

  ModIface
final_iface' <- HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
mkFullIface HscEnv
session PartialModIface
partial_iface forall a. Maybe a
Nothing
#if MIN_VERSION_ghc(9,4,2)
                    Nothing
#endif
  let final_iface :: ModIface
final_iface = ModIface
final_iface' {mi_globals :: Maybe GlobalRdrEnv
mi_globals = forall a. Maybe a
Nothing, mi_usages :: [Usage]
mi_usages = [Usage] -> [Usage]
filterUsages (forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages ModIface
final_iface')} -- See Note [Clearing mi_globals after generating an iface]

  -- Write the core file now
  Maybe (CoreFile, ByteString)
core_file <- do
        let core_fp :: [Char]
core_fp  = ModLocation -> [Char]
ml_core_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
ms
            core_file :: CoreFile
core_file = Fingerprint -> CgGuts -> CoreFile
codeGutsToCoreFile Fingerprint
iface_hash CgGuts
guts
            iface_hash :: Fingerprint
iface_hash = ModIface -> Fingerprint
getModuleHash ModIface
final_iface
        Fingerprint
core_hash1 <- forall a. ShakeExtras -> [Char] -> ([Char] -> IO a) -> IO a
atomicFileWrite ShakeExtras
se [Char]
core_fp forall a b. (a -> b) -> a -> b
$ \[Char]
fp ->
          [Char] -> CoreFile -> IO Fingerprint
writeBinCoreFile [Char]
fp CoreFile
core_file
        -- We want to drop references to guts and read in a serialized, compact version
        -- of the core file from disk (as it is deserialised lazily)
        -- This is because we don't want to keep the guts in memory for every file in
        -- the project as it becomes prohibitively expensive
        -- The serialized file however is much more compact and only requires a few
        -- hundred megabytes of memory total even in a large project with 1000s of
        -- modules
        (CoreFile
coreFile, !Fingerprint
core_hash2) <- NameCacheUpdater -> [Char] -> IO (CoreFile, Fingerprint)
readBinCoreFile (IORef NameCache -> NameCacheUpdater
mkUpdater forall a b. (a -> b) -> a -> b
$ HscEnv -> IORef NameCache
hsc_NC HscEnv
session) [Char]
core_fp
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Fingerprint
core_hash1 forall a. Eq a => a -> a -> Bool
== Fingerprint
core_hash2)
             forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (CoreFile
coreFile, Fingerprint -> ByteString
fingerprintToBS Fingerprint
core_hash2)

  -- Verify core file by roundtrip testing and comparison
  IdeOptions{Bool
optVerifyCoreFile :: Bool
optVerifyCoreFile :: IdeOptions -> Bool
optVerifyCoreFile} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
se
  case Maybe (CoreFile, ByteString)
core_file of
    Just (CoreFile
core, ByteString
_) | Bool
optVerifyCoreFile -> do
      let core_fp :: [Char]
core_fp = ModLocation -> [Char]
ml_core_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
ms
      [Char] -> IO ()
traceIO forall a b. (a -> b) -> a -> b
$ [Char]
"Verifying " forall a. [a] -> [a] -> [a]
++ [Char]
core_fp
      let CgGuts{cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
unprep_binds, cg_tycons :: CgGuts -> [TyCon]
cg_tycons = [TyCon]
tycons } = CgGuts
guts
          mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
ms
          data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
      CgGuts{cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
unprep_binds'} <- HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts HscEnv
session ModIface
final_iface ModDetails
details CoreFile
core

#if MIN_VERSION_ghc(9,5,0)
      cp_cfg <- initCorePrepConfig session
#endif

      let corePrep :: CoreProgram -> [TyCon] -> IO (CoreProgram, Set CostCentre)
corePrep = HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm
#if MIN_VERSION_ghc(9,5,0)
                       (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session))
#else
                       HscEnv
session
#endif
                       Module
mod (ModSummary -> ModLocation
ms_location ModSummary
ms)

      -- Run corePrep first as we want to test the final version of the program that will
      -- get translated to STG/Bytecode
#if MIN_VERSION_ghc(9,3,0)
      prepd_binds
#else
      (CoreProgram
prepd_binds , Set CostCentre
_)
#endif
        <- CoreProgram -> [TyCon] -> IO (CoreProgram, Set CostCentre)
corePrep CoreProgram
unprep_binds [TyCon]
data_tycons
#if MIN_VERSION_ghc(9,3,0)
      prepd_binds'
#else
      (CoreProgram
prepd_binds', Set CostCentre
_)
#endif
        <- CoreProgram -> [TyCon] -> IO (CoreProgram, Set CostCentre)
corePrep CoreProgram
unprep_binds' [TyCon]
data_tycons
      let binds :: [[(Id, CoreExpr)]]
binds  = [[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]]
noUnfoldings forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map forall b. [Bind b] -> [(b, Expr b)]
flattenBinds forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])) CoreProgram
prepd_binds
          binds' :: [[(Id, CoreExpr)]]
binds' = [[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]]
noUnfoldings forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map forall b. [Bind b] -> [(b, Expr b)]
flattenBinds forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])) CoreProgram
prepd_binds'

          -- diffBinds is unreliable, sometimes it goes down the wrong track.
          -- This fixes the order of the bindings so that it is less likely to do so.
          diffs2 :: [SDoc]
diffs2 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
S.evalState (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {m :: * -> *}.
Monad m =>
[(Id, CoreExpr)] -> [(Id, CoreExpr)] -> StateT RnEnv2 m [SDoc]
go [[(Id, CoreExpr)]]
binds [[(Id, CoreExpr)]]
binds'
          -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')
          -- diffs3  = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')

          diffs :: [SDoc]
diffs = [SDoc]
diffs2
          go :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> StateT RnEnv2 m [SDoc]
go [(Id, CoreExpr)]
x [(Id, CoreExpr)]
y = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
S.state forall a b. (a -> b) -> a -> b
$ \RnEnv2
s -> Bool
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
True RnEnv2
s [(Id, CoreExpr)]
x [(Id, CoreExpr)]
y

          -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these
          -- are used for generate core or bytecode, so we can safely ignore them
          -- SYB is slow but fine given that this is only used for testing
          noUnfoldings :: [[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]]
noUnfoldings = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere forall a b. (a -> b) -> a -> b
$ forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT forall a b. (a -> b) -> a -> b
$ \Id
v -> if Id -> Bool
isId Id
v
            then
              let v' :: Id
v' = if Unfolding -> Bool
isOtherUnfolding (Id -> Unfolding
realIdUnfolding Id
v) then (Id -> Unfolding -> Id
setIdUnfolding Id
v Unfolding
noUnfolding) else Id
v
                in Id -> OccInfo -> Id
setIdOccInfo Id
v' OccInfo
noOccInfo
            else Id
v
          isOtherUnfolding :: Unfolding -> Bool
isOtherUnfolding (OtherCon [AltCon]
_) = Bool
True
          isOtherUnfolding Unfolding
_            = Bool
False


      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
diffs) forall a b. (a -> b) -> a -> b
$
        forall a. [Char] -> SDoc -> a
panicDoc [Char]
"verify core failed!" ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate ([Char] -> SDoc
text [Char]
"\n\n") [SDoc]
diffs) -- ++ [ppr binds , ppr binds']))
    Maybe (CoreFile, ByteString)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! ModSummary
-> ModIface
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface
final_iface ModDetails
details (TcModuleResult -> ModuleEnv ByteString
tmrRuntimeModules TcModuleResult
tcm) Maybe (CoreFile, ByteString)
core_file)

  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
session'
    source :: Text
source = Text
"compile"
    catchErrs :: IO (IdeResult HiFileResult) -> IO (IdeResult HiFileResult)
catchErrs IO (IdeResult HiFileResult)
x = IO (IdeResult HiFileResult)
x forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches`
      [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
source DynFlags
dflags
      , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DiagnosticSeverity -> SrcSpan -> [Char] -> [FileDiagnostic]
diagFromString Text
source DiagnosticSeverity
DiagnosticSeverity_Error ([Char] -> SrcSpan
noSpan [Char]
"<internal>")
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
"Error during " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
source) forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @SomeException
      ]

-- | Whether we should run the -O0 simplifier when generating core.
--
-- This is required for template Haskell to work but we disable this in DAML.
-- See #256
newtype RunSimplifier = RunSimplifier Bool

-- | Compile a single type-checked module to a 'CoreModule' value, or
-- provide errors.
compileModule
    :: RunSimplifier
    -> HscEnv
    -> ModSummary
    -> TcGblEnv
    -> IO (IdeResult ModGuts)
compileModule :: RunSimplifier
-> HscEnv -> ModSummary -> TcGblEnv -> IO (IdeResult ModGuts)
compileModule (RunSimplifier Bool
simplify) HscEnv
session ModSummary
ms TcGblEnv
tcg =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, forall a. Maybe a
Nothing) (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> Maybe a
Just)) forall a b. (a -> b) -> a -> b
$
        forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
session) Text
"compile" forall a b. (a -> b) -> a -> b
$ do
            ([(WarnReason, FileDiagnostic)]
warnings,ModGuts
desugared_guts) <- forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"compile" forall a b. (a -> b) -> a -> b
$ \HscEnv -> HscEnv
tweak -> do
                 -- Breakpoints don't survive roundtripping from disk
                 -- and this trips up the verify-core-files check
                 -- They may also lead to other problems.
                 -- We have to setBackend ghciBackend in 9.8 as otherwise
                 -- non-exported definitions are stripped out.
                 -- However, setting this means breakpoints are generated.
                 -- Solution: prevent breakpoing generation by unsetting
                 -- Opt_InsertBreakpoints
               let session' :: HscEnv
session' = HscEnv -> HscEnv
tweak forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> HscEnv -> HscEnv
hscSetFlags HscEnv
session
#if MIN_VERSION_ghc(9,7,0)
                                    $ flip gopt_unset Opt_InsertBreakpoints
                                    $ setBackend ghciBackend
#endif
                                    forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
               -- TODO: maybe settings ms_hspp_opts is unnecessary?
               -- MP: the flags in ModSummary should be right, if they are wrong then
               -- the correct place to fix this is when the ModSummary is created.
               ModGuts
desugar <- HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
session' (ModSummary
ms { ms_hspp_opts :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
session' }) TcGblEnv
tcg
               if Bool
simplify
               then do
                 [[Char]]
plugins <- forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef [[Char]]
tcg_th_coreplugins TcGblEnv
tcg)
                 HscEnv -> [[Char]] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
session' [[Char]]
plugins ModGuts
desugar
               else forall (f :: * -> *) a. Applicative f => a -> f a
pure ModGuts
desugar
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(WarnReason, FileDiagnostic)]
warnings, ModGuts
desugared_guts)

generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode HscEnv
session ModSummary
summary CgGuts
guts = do
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, forall a. Maybe a
Nothing) (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> Maybe a
Just)) forall a b. (a -> b) -> a -> b
$
          forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
session) Text
"object" forall a b. (a -> b) -> a -> b
$ do
              let dot_o :: [Char]
dot_o =  ModLocation -> [Char]
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
                  mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
summary
                  fp :: [Char]
fp = [Char] -> [Char] -> [Char]
replaceExtension [Char]
dot_o [Char]
"s"
              Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> [Char]
takeDirectory [Char]
fp)
              ([(WarnReason, FileDiagnostic)]
warnings, [Char]
dot_o_fp) <-
                forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"object" forall a b. (a -> b) -> a -> b
$ \HscEnv -> HscEnv
tweak -> do
                      let env' :: HscEnv
env' = HscEnv -> HscEnv
tweak (DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary) HscEnv
session)
                          target :: Backend
target = DynFlags -> Backend
platformDefaultBackend (HscEnv -> DynFlags
hsc_dflags HscEnv
env')
                          newFlags :: DynFlags
newFlags = Backend -> DynFlags -> DynFlags
setBackend Backend
target forall a b. (a -> b) -> a -> b
$ Int -> DynFlags -> DynFlags
updOptLevel Int
0 forall a b. (a -> b) -> a -> b
$ [Char] -> DynFlags -> DynFlags
setOutputFile
#if MIN_VERSION_ghc(9,3,0)
                              (Just dot_o)
#else
                              [Char]
dot_o
#endif
                            forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
env'
                          session' :: HscEnv
session' = DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
newFlags HscEnv
session
#if MIN_VERSION_ghc(9,4,2)
                      (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts
#else
                      ([Char]
outputFilename, Maybe [Char]
_mStub, [(ForeignSrcLang, [Char])]
_foreign_files, CgInfos
_cinfos) <- HscEnv
-> CgGuts
-> ModLocation
-> [Char]
-> IO ([Char], Maybe [Char], [(ForeignSrcLang, [Char])], CgInfos)
hscGenHardCode HscEnv
session' CgGuts
guts
#endif
                                (ModSummary -> ModLocation
ms_location ModSummary
summary)
                                [Char]
fp
                      [Char]
obj <- HscEnv -> Phase -> ([Char], Maybe Phase) -> IO [Char]
compileFile HscEnv
session' Phase
driverNoStop ([Char]
outputFilename, forall a. a -> Maybe a
Just (Bool -> Phase
As Bool
False))
#if MIN_VERSION_ghc(9,3,0)
                      case obj of
                        Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code"
                        Just x -> pure x
#else
                      forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
obj
#endif
              let unlinked :: Unlinked
unlinked = [Char] -> Unlinked
DotO [Char]
dot_o_fp
              -- Need time to be the modification time for recompilation checking
              UTCTime
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO UTCTime
getModificationTime [Char]
dot_o_fp
              let linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
t Module
mod [Unlinked
unlinked]

              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(WarnReason, FileDiagnostic)]
warnings, Linkable
linkable)

newtype CoreFileTime = CoreFileTime UTCTime

generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode :: CoreFileTime
-> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode (CoreFileTime UTCTime
time) HscEnv
hscEnv ModSummary
summary CgGuts
guts = do
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, forall a. Maybe a
Nothing) (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> Maybe a
Just)) forall a b. (a -> b) -> a -> b
$
          forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv) Text
"bytecode" forall a b. (a -> b) -> a -> b
$ do
              ([(WarnReason, FileDiagnostic)]
warnings, (Maybe [Char]
_, CompiledByteCode
bytecode, [SptEntry]
sptEntries)) <-
                forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"bytecode" forall a b. (a -> b) -> a -> b
$ \HscEnv -> HscEnv
_tweak -> do
                      let session :: HscEnv
session = HscEnv -> HscEnv
_tweak (DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary) HscEnv
hscEnv)
                          -- TODO: maybe settings ms_hspp_opts is unnecessary?
                          summary' :: ModSummary
summary' = ModSummary
summary { ms_hspp_opts :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
session }
                      HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe [Char], CompiledByteCode, [SptEntry])
hscInteractive HscEnv
session (CgGuts -> CgGuts
mkCgInteractiveGuts CgGuts
guts)
                                (ModSummary -> ModLocation
ms_location ModSummary
summary')
              let unlinked :: Unlinked
unlinked = CompiledByteCode -> [SptEntry] -> Unlinked
BCOs CompiledByteCode
bytecode [SptEntry]
sptEntries
              let linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
time (ModSummary -> Module
ms_mod ModSummary
summary) [Unlinked
unlinked]
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(WarnReason, FileDiagnostic)]
warnings, Linkable
linkable)

demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings =
  ((ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
update_pm_mod_summary forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> DynFlags) -> ModSummary -> ModSummary
update_hspp_opts) DynFlags -> DynFlags
demoteTEsToWarns where

  demoteTEsToWarns :: DynFlags -> DynFlags
  -- convert the errors into warnings, and also check the warnings are enabled
  demoteTEsToWarns :: DynFlags -> DynFlags
demoteTEsToWarns = (DynFlags -> WarningFlag -> DynFlags
`wopt_set` WarningFlag
Opt_WarnDeferredTypeErrors)
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> WarningFlag -> DynFlags
`wopt_set` WarningFlag
Opt_WarnTypedHoles)
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> WarningFlag -> DynFlags
`wopt_set` WarningFlag
Opt_WarnDeferredOutOfScopeVariables)
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_DeferTypeErrors)
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_DeferTypedHoles)
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_DeferOutOfScopeVariables)

update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
update_hspp_opts DynFlags -> DynFlags
up ModSummary
ms = ModSummary
ms{ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> DynFlags
up forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms}

update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
update_pm_mod_summary ModSummary -> ModSummary
up ParsedModule
pm =
  ParsedModule
pm{pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary -> ModSummary
up forall a b. (a -> b) -> a -> b
$ ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pm}

#if MIN_VERSION_ghc(9,3,0)
unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors)         , fd) = (True, upgradeWarningToError fd)
unDefer (Just (WarningWithFlag Opt_WarnTypedHoles)                 , fd) = (True, upgradeWarningToError fd)
unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd)
#else
unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer (Reason WarningFlag
Opt_WarnDeferredTypeErrors         , FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
unDefer (Reason WarningFlag
Opt_WarnTypedHoles                 , FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
unDefer (Reason WarningFlag
Opt_WarnDeferredOutOfScopeVariables, FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
#endif
unDefer ( WarnReason
_                                        , FileDiagnostic
fd) = (Bool
False, FileDiagnostic
fd)

upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
upgradeWarningToError (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd) =
  (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd{$sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Error, $sel:_message:Diagnostic :: Text
_message = Text -> Text
warn2err forall a b. (a -> b) -> a -> b
$ Diagnostic -> Text
_message Diagnostic
fd}) where
  warn2err :: T.Text -> T.Text
  warn2err :: Text -> Text
warn2err = Text -> [Text] -> Text
T.intercalate Text
": error:" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
": warning:"

#if MIN_VERSION_ghc(9,3,0)
hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))
#else
hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
hideDiag :: DynFlags
-> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
hideDiag DynFlags
originalFlags (w :: WarnReason
w@(Reason WarningFlag
warning), (NormalizedFilePath
nfp, ShowDiagnostic
_sh, Diagnostic
fd))
#endif
  | Bool -> Bool
not (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
warning DynFlags
originalFlags)
  = (WarnReason
w, (NormalizedFilePath
nfp, ShowDiagnostic
HideDiag, Diagnostic
fd))
hideDiag DynFlags
_originalFlags (WarnReason, FileDiagnostic)
t = (WarnReason, FileDiagnostic)
t

-- | Warnings which lead to a diagnostic tag
unnecessaryDeprecationWarningFlags :: [WarningFlag]
unnecessaryDeprecationWarningFlags :: [WarningFlag]
unnecessaryDeprecationWarningFlags
  = [ WarningFlag
Opt_WarnUnusedTopBinds
    , WarningFlag
Opt_WarnUnusedLocalBinds
    , WarningFlag
Opt_WarnUnusedPatternBinds
    , WarningFlag
Opt_WarnUnusedImports
    , WarningFlag
Opt_WarnUnusedMatches
    , WarningFlag
Opt_WarnUnusedTypePatterns
    , WarningFlag
Opt_WarnUnusedForalls
    , WarningFlag
Opt_WarnUnusedRecordWildcards
    , WarningFlag
Opt_WarnInaccessibleCode
#if !MIN_VERSION_ghc(9,7,0)
    , WarningFlag
Opt_WarnWarningsDeprecations
#endif
    ]

-- | Add a unnecessary/deprecated tag to the required diagnostics.
#if MIN_VERSION_ghc(9,3,0)
tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
#else
tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
#endif

#if MIN_VERSION_ghc(9,7,0)
tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd))
  | cat == defaultWarningCategory -- default warning category is for deprecations
  = (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) }))
tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd))
  | tags <- mapMaybe requiresTag (toList warnings)
  = (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) }))
#elif MIN_VERSION_ghc(9,3,0)
tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))
  | Just tag <- requiresTag warning
  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))
#else
tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
tagDiag (w :: WarnReason
w@(Reason WarningFlag
warning), (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd))
  | Just DiagnosticTag
tag <- WarningFlag -> Maybe DiagnosticTag
requiresTag WarningFlag
warning
  = (WarnReason
w, (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd { $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DiagnosticTag
tag forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Diagnostic -> Maybe [DiagnosticTag]
_tags Diagnostic
fd) }))
#endif
  where
    requiresTag :: WarningFlag -> Maybe DiagnosticTag
#if !MIN_VERSION_ghc(9,7,0)
    -- doesn't exist on 9.8, we use WarningWithCategory instead
    requiresTag :: WarningFlag -> Maybe DiagnosticTag
requiresTag WarningFlag
Opt_WarnWarningsDeprecations
      = forall a. a -> Maybe a
Just DiagnosticTag
DiagnosticTag_Deprecated
#endif
    requiresTag WarningFlag
wflag  -- deprecation was already considered above
      | WarningFlag
wflag forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WarningFlag]
unnecessaryDeprecationWarningFlags
      = forall a. a -> Maybe a
Just DiagnosticTag
DiagnosticTag_Unnecessary
    requiresTag WarningFlag
_ = forall a. Maybe a
Nothing
-- other diagnostics are left unaffected
tagDiag (WarnReason, FileDiagnostic)
t = (WarnReason, FileDiagnostic)
t

addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
addRelativeImport NormalizedFilePath
fp ModuleName
modu DynFlags
dflags = DynFlags
dflags
    {importPaths :: [[Char]]
importPaths = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList (NormalizedFilePath -> ModuleName -> Maybe [Char]
moduleImportPath NormalizedFilePath
fp ModuleName
modu) forall a. [a] -> [a] -> [a]
++ DynFlags -> [[Char]]
importPaths DynFlags
dflags}

-- | Also resets the interface store
atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
atomicFileWrite :: forall a. ShakeExtras -> [Char] -> ([Char] -> IO a) -> IO a
atomicFileWrite ShakeExtras
se [Char]
targetPath [Char] -> IO a
write = do
  let dir :: [Char]
dir = [Char] -> [Char]
takeDirectory [Char]
targetPath
  Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
  ([Char]
tempFilePath, IO ()
cleanUp) <- [Char] -> IO ([Char], IO ())
newTempFileWithin [Char]
dir
  ([Char] -> IO a
write [Char]
tempFilePath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> [Char] -> [Char] -> IO ()
renameFile [Char]
tempFilePath [Char]
targetPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. STM a -> IO a
atomically (ShakeExtras -> NormalizedFilePath -> STM ()
resetInterfaceStore ShakeExtras
se ([Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
targetPath)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
    forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`onException` IO ()
cleanUp

generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts :: HscEnv
-> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts HscEnv
hscEnv TcModuleResult
tcm =
  forall a.
DynFlags -> Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
handleGenerationErrors' DynFlags
dflags Text
"extended interface generation" forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hscEnv forall a b. (a -> b) -> a -> b
$ do
    -- These varBinds use unitDataConId but it could be anything as the id name is not used
    -- during the hie file generation process. It's a workaround for the fact that the hie modules
    -- don't export an interface which allows for additional information to be added to hie files.
    let fake_splice_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
fake_splice_binds = forall a. [a] -> Bag a
Util.listToBag (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
unitDataConId) (Splices -> [LHsExpr GhcTc]
spliceExpressions forall a b. (a -> b) -> a -> b
$ TcModuleResult -> Splices
tmrTopLevelSplices TcModuleResult
tcm))
        real_binds :: LHsBinds GhcTc
real_binds = TcGblEnv -> LHsBinds GhcTc
tcg_binds forall a b. (a -> b) -> a -> b
$ TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tcm
        ts :: TcGblEnv
ts = TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tcm :: TcGblEnv
        top_ev_binds :: Bag EvBind
top_ev_binds = TcGblEnv -> Bag EvBind
tcg_ev_binds TcGblEnv
ts :: Util.Bag EvBind
        insts :: [ClsInst]
insts = TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
ts :: [ClsInst]
        tcs :: [TyCon]
tcs = TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
ts :: [TyCon]
    TcGblEnv
-> DsM (Maybe (HieASTs Type)) -> Hsc (Maybe (HieASTs Type))
run TcGblEnv
ts forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_ghc(9,3,0)
      pure $ Just $
#else
      forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
#endif
          LHsBinds GhcTc
-> RenamedSource
-> Bag EvBind
-> [ClsInst]
-> [TyCon]
-> DsM (HieASTs Type)
GHC.enrichHie (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
fake_splice_binds forall a. Bag a -> Bag a -> Bag a
`Util.unionBags` LHsBinds GhcTc
real_binds) (TcModuleResult -> RenamedSource
tmrRenamed TcModuleResult
tcm) Bag EvBind
top_ev_binds [ClsInst]
insts [TyCon]
tcs
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv
    run :: TcGblEnv
-> DsM (Maybe (HieASTs Type)) -> Hsc (Maybe (HieASTs Type))
run TcGblEnv
_ts = -- ts is only used in GHC 9.2
#if !MIN_VERSION_ghc(9,3,0)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
initDs HscEnv
hscEnv TcGblEnv
_ts
#else
        id
#endif

spliceExpressions :: Splices -> [LHsExpr GhcTc]
spliceExpressions :: Splices -> [LHsExpr GhcTc]
spliceExpressions Splices{[(LHsExpr GhcTc, [LHsDecl GhcPs])]
[(LHsExpr GhcTc, Serialized)]
[(LHsExpr GhcTc, LHsType GhcPs)]
[(LHsExpr GhcTc, LPat GhcPs)]
[(LHsExpr GhcTc, LHsExpr GhcPs)]
awSplices :: Splices -> [(LHsExpr GhcTc, Serialized)]
declSplices :: Splices -> [(LHsExpr GhcTc, [LHsDecl GhcPs])]
typeSplices :: Splices -> [(LHsExpr GhcTc, LHsType GhcPs)]
patSplices :: Splices -> [(LHsExpr GhcTc, LPat GhcPs)]
exprSplices :: Splices -> [(LHsExpr GhcTc, LHsExpr GhcPs)]
awSplices :: [(LHsExpr GhcTc, Serialized)]
declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])]
typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)]
patSplices :: [(LHsExpr GhcTc, LPat GhcPs)]
exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)]
..} =
    forall a. DList a -> [a]
DL.toList forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ forall a. [a] -> DList a
DL.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LHsExpr GhcTc, LHsExpr GhcPs)]
exprSplices
        , forall a. [a] -> DList a
DL.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LHsExpr GhcTc, LPat GhcPs)]
patSplices
        , forall a. [a] -> DList a
DL.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LHsExpr GhcTc, LHsType GhcPs)]
typeSplices
        , forall a. [a] -> DList a
DL.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LHsExpr GhcTc, [LHsDecl GhcPs])]
declSplices
        , forall a. [a] -> DList a
DL.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LHsExpr GhcTc, Serialized)]
awSplices
        ]

-- | In addition to indexing the `.hie` file, this function is responsible for
-- maintaining the 'IndexQueue' state and notifying the user about indexing
-- progress.
--
-- We maintain a record of all pending index operations in the 'indexPending'
-- TVar.
-- When 'indexHieFile' is called, it must check to ensure that the file hasn't
-- already be queued up for indexing. If it has, then we can just skip it
--
-- Otherwise, we record the current file as pending and write an indexing
-- operation to the queue
--
-- When the indexing operation is picked up and executed by the worker thread,
-- the first thing it does is ensure that a newer index for the same file hasn't
-- been scheduled by looking at 'indexPending'. If a newer index has been
-- scheduled, we can safely skip this one
--
-- Otherwise, we start or continue a progress reporting session, telling it
-- about progress so far and the current file we are attempting to index. Then
-- we can go ahead and call in to hiedb to actually do the indexing operation
--
-- Once this completes, we have to update the 'IndexQueue' state. First, we
-- must remove the just indexed file from 'indexPending' Then we check if
-- 'indexPending' is now empty. In that case, we end the progress session and
-- report the total number of file indexed. We also set the 'indexCompleted'
-- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we
-- can just increment the 'indexCompleted' TVar and exit.
--
indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO ()
indexHieFile :: ShakeExtras
-> ModSummary
-> NormalizedFilePath
-> Fingerprint
-> HieFile
-> IO ()
indexHieFile ShakeExtras
se ModSummary
mod_summary NormalizedFilePath
srcPath !Fingerprint
hash HieFile
hf = do
 IdeOptions{ProgressReportingStyle
optProgressStyle :: ProgressReportingStyle
optProgressStyle :: IdeOptions -> ProgressReportingStyle
optProgressStyle} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
se
 forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
  HashMap NormalizedFilePath Fingerprint
pending <- forall a. TVar a -> STM a
readTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending
  case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup NormalizedFilePath
srcPath HashMap NormalizedFilePath Fingerprint
pending of
    Just Fingerprint
pendingHash | Fingerprint
pendingHash forall a. Eq a => a -> a -> Bool
== Fingerprint
hash -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- An index is already scheduled
    Maybe Fingerprint
_ -> do
      -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
      let !hf' :: HieFile
hf' = HieFile
hf{hie_hs_src :: ByteString
hie_hs_src = forall a. Monoid a => a
mempty}
      forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashMap NormalizedFilePath Fingerprint)
indexPending forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert NormalizedFilePath
srcPath Fingerprint
hash
      forall a. TQueue a -> a -> STM ()
writeTQueue IndexQueue
indexQueue forall a b. (a -> b) -> a -> b
$ \(HieDb -> IO ()) -> IO ()
withHieDb -> do
        -- We are now in the worker thread
        -- Check if a newer index of this file has been scheduled, and if so skip this one
        Bool
newerScheduled <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
          HashMap NormalizedFilePath Fingerprint
pendingOps <- forall a. TVar a -> STM a
readTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup NormalizedFilePath
srcPath HashMap NormalizedFilePath Fingerprint
pendingOps of
            Maybe Fingerprint
Nothing          -> Bool
False
            -- If the hash in the pending list doesn't match the current hash, then skip
            Just Fingerprint
pendingHash -> Fingerprint
pendingHash forall a. Eq a => a -> a -> Bool
/= Fingerprint
hash
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newerScheduled forall a b. (a -> b) -> a -> b
$ do
          -- Using bracket, so even if an exception happen during withHieDb call,
          -- the `post` (which clean the progress indicator) will still be called.
          forall (m :: * -> *) a b c. MonadMask m => m a -> m b -> m c -> m c
bracket_ (ProgressReportingStyle -> IO ()
pre ProgressReportingStyle
optProgressStyle) IO ()
post forall a b. (a -> b) -> a -> b
$
            (HieDb -> IO ()) -> IO ()
withHieDb (\HieDb
db -> forall (m :: * -> *).
MonadIO m =>
HieDb -> [Char] -> SourceFile -> Fingerprint -> HieFile -> m ()
HieDb.addRefsFromLoaded HieDb
db [Char]
targetPath ([Char] -> SourceFile
HieDb.RealFile forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
srcPath) Fingerprint
hash HieFile
hf')
  where
    mod_location :: ModLocation
mod_location    = ModSummary -> ModLocation
ms_location ModSummary
mod_summary
    targetPath :: [Char]
targetPath      = ModLocation -> [Char]
Compat.ml_hie_file ModLocation
mod_location
    HieDbWriter{TVar Int
TVar (HashMap NormalizedFilePath Fingerprint)
Var (Maybe ProgressToken)
IndexQueue
$sel:indexProgressToken:HieDbWriter :: HieDbWriter -> Var (Maybe ProgressToken)
$sel:indexCompleted:HieDbWriter :: HieDbWriter -> TVar Int
$sel:indexPending:HieDbWriter :: HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
$sel:indexQueue:HieDbWriter :: HieDbWriter -> IndexQueue
indexProgressToken :: Var (Maybe ProgressToken)
indexCompleted :: TVar Int
indexQueue :: IndexQueue
indexPending :: TVar (HashMap NormalizedFilePath Fingerprint)
..} = ShakeExtras -> HieDbWriter
hiedbWriter ShakeExtras
se

    -- Get a progress token to report progress and update it for the current file
    pre :: ProgressReportingStyle -> IO ()
pre ProgressReportingStyle
style = do
      Maybe ProgressToken
tok <- forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (Maybe ProgressToken)
indexProgressToken forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> (a, a)
dupe forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        x :: Maybe ProgressToken
x@(Just ProgressToken
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ProgressToken
x
        -- Create a token if we don't already have one
        Maybe ProgressToken
Nothing -> do
          case ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se of
            Maybe (LanguageContextEnv Config)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just LanguageContextEnv Config
env -> forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env forall a b. (a -> b) -> a -> b
$ do
              ProgressToken
u <- (Int32 |? Text) -> ProgressToken
LSP.ProgressToken forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> a |? b
LSP.InR forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
Unique.newUnique
              -- TODO: Wait for the progress create response to use the token
              LspId 'Method_WindowWorkDoneProgressCreate
_ <- forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SMethod 'Method_WindowWorkDoneProgressCreate
LSP.SMethod_WindowWorkDoneProgressCreate (ProgressToken -> WorkDoneProgressCreateParams
LSP.WorkDoneProgressCreateParams ProgressToken
u) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification forall {f :: MessageDirection}. SMethod 'Method_Progress
LSP.SMethod_Progress forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
LSP.ProgressParams ProgressToken
u forall a b. (a -> b) -> a -> b
$
                forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ LSP.WorkDoneProgressBegin
                  { $sel:_kind:WorkDoneProgressBegin :: AString "begin"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
LSP.AString @"begin"
                  ,  $sel:_title:WorkDoneProgressBegin :: Text
_title = Text
"Indexing"
                  , $sel:_cancellable:WorkDoneProgressBegin :: Maybe Bool
_cancellable = forall a. Maybe a
Nothing
                  , $sel:_message:WorkDoneProgressBegin :: Maybe Text
_message = forall a. Maybe a
Nothing
                  , $sel:_percentage:WorkDoneProgressBegin :: Maybe UInt
_percentage = forall a. Maybe a
Nothing
                  }
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ProgressToken
u)

      (!Int
done, !Int
remaining) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        Int
done <- forall a. TVar a -> STM a
readTVar TVar Int
indexCompleted
        Int
remaining <- forall k v. HashMap k v -> Int
HashMap.size forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
done, Int
remaining)
      let
        progressFrac :: Double
        progressFrac :: Double
progressFrac = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
done forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
done forall a. Num a => a -> a -> a
+ Int
remaining)
        progressPct :: LSP.UInt
        progressPct :: UInt
progressPct = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Double
100 forall a. Num a => a -> a -> a
* Double
progressFrac

      forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env -> forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProgressToken
tok forall a b. (a -> b) -> a -> b
$ \ProgressToken
token -> forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env forall a b. (a -> b) -> a -> b
$
        forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification forall {f :: MessageDirection}. SMethod 'Method_Progress
LSP.SMethod_Progress forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
LSP.ProgressParams ProgressToken
token forall a b. (a -> b) -> a -> b
$
          forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$
            case ProgressReportingStyle
style of
                ProgressReportingStyle
Percentage -> LSP.WorkDoneProgressReport
                    { $sel:_kind:WorkDoneProgressReport :: AString "report"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
LSP.AString @"report"
                    , $sel:_cancellable:WorkDoneProgressReport :: Maybe Bool
_cancellable = forall a. Maybe a
Nothing
                    , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = forall a. Maybe a
Nothing
                    , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = forall a. a -> Maybe a
Just UInt
progressPct
                    }
                ProgressReportingStyle
Explicit -> LSP.WorkDoneProgressReport
                    { $sel:_kind:WorkDoneProgressReport :: AString "report"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
LSP.AString @"report"
                    , $sel:_cancellable:WorkDoneProgressReport :: Maybe Bool
_cancellable = forall a. Maybe a
Nothing
                    , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                        [Char] -> Text
T.pack [Char]
" (" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int
done) forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Int
done forall a. Num a => a -> a -> a
+ Int
remaining) forall a. Semigroup a => a -> a -> a
<> Text
")..."
                    , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = forall a. Maybe a
Nothing
                    }
                ProgressReportingStyle
NoProgress -> LSP.WorkDoneProgressReport
                  { $sel:_kind:WorkDoneProgressReport :: AString "report"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
LSP.AString @"report"
                  , $sel:_cancellable:WorkDoneProgressReport :: Maybe Bool
_cancellable = forall a. Maybe a
Nothing
                  , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = forall a. Maybe a
Nothing
                  , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = forall a. Maybe a
Nothing
                  }

    -- Report the progress once we are done indexing this file
    post :: IO ()
post = do
      Maybe Int
mdone <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        -- Remove current element from pending
        HashMap NormalizedFilePath Fingerprint
pending <- forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending forall a b. (a -> b) -> a -> b
$
          forall a. a -> (a, a)
dupe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a.
(Eq k, Hashable k) =>
(a -> Maybe a) -> k -> HashMap k a -> HashMap k a
HashMap.update (\Fingerprint
pendingHash -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Fingerprint
pendingHash forall a. Eq a => a -> a -> Bool
/= Fingerprint
hash) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Fingerprint
pendingHash) NormalizedFilePath
srcPath
        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
indexCompleted (forall a. Num a => a -> a -> a
+Int
1)
        -- If we are done, report and reset completed
        forall (m :: * -> *) a. Applicative m => Bool -> m a -> m (Maybe a)
whenMaybe (forall k v. HashMap k v -> Bool
HashMap.null HashMap NormalizedFilePath Fingerprint
pending) forall a b. (a -> b) -> a -> b
$
          forall a. TVar a -> a -> STM a
swapTVar TVar Int
indexCompleted Int
0
      forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env -> forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IdeTesting
ideTesting ShakeExtras
se) forall a b. (a -> b) -> a -> b
$
          forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
LSP.SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"ghcide/reference/ready")) forall a b. (a -> b) -> a -> b
$
            forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
srcPath
      forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
mdone forall a b. (a -> b) -> a -> b
$ \Int
done ->
        forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (Maybe ProgressToken)
indexProgressToken forall a b. (a -> b) -> a -> b
$ \Maybe ProgressToken
tok -> do
          forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env -> forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProgressToken
tok forall a b. (a -> b) -> a -> b
$ \ProgressToken
token ->
              forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification forall {f :: MessageDirection}. SMethod 'Method_Progress
LSP.SMethod_Progress  forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
LSP.ProgressParams ProgressToken
token forall a b. (a -> b) -> a -> b
$
                forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$
                LSP.WorkDoneProgressEnd
                  { $sel:_kind:WorkDoneProgressEnd :: AString "end"
_kind = forall (s :: Symbol). KnownSymbol s => AString s
LSP.AString @"end"
                  , $sel:_message:WorkDoneProgressEnd :: Maybe Text
_message = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"Finished indexing " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int
done) forall a. Semigroup a => a -> a -> a
<> Text
" files"
                  }
          -- We are done with the current indexing cycle, so destroy the token
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
writeAndIndexHieFile :: HscEnv
-> ShakeExtras
-> ModSummary
-> NormalizedFilePath
-> Avails
-> HieASTs Type
-> ByteString
-> IO [FileDiagnostic]
writeAndIndexHieFile HscEnv
hscEnv ShakeExtras
se ModSummary
mod_summary NormalizedFilePath
srcPath Avails
exports HieASTs Type
ast ByteString
source =
  DynFlags -> Text -> IO () -> IO [FileDiagnostic]
handleGenerationErrors DynFlags
dflags Text
"extended interface write/compression" forall a b. (a -> b) -> a -> b
$ do
    HieFile
hf <- forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hscEnv forall a b. (a -> b) -> a -> b
$
      ModSummary -> Avails -> HieASTs Type -> ByteString -> Hsc HieFile
GHC.mkHieFile' ModSummary
mod_summary Avails
exports HieASTs Type
ast ByteString
source
    forall a. ShakeExtras -> [Char] -> ([Char] -> IO a) -> IO a
atomicFileWrite ShakeExtras
se [Char]
targetPath forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> HieFile -> IO ()
GHC.writeHieFile HieFile
hf
    Fingerprint
hash <- [Char] -> IO Fingerprint
Util.getFileHash [Char]
targetPath
    ShakeExtras
-> ModSummary
-> NormalizedFilePath
-> Fingerprint
-> HieFile
-> IO ()
indexHieFile ShakeExtras
se ModSummary
mod_summary NormalizedFilePath
srcPath Fingerprint
hash HieFile
hf
  where
    dflags :: DynFlags
dflags       = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv
    mod_location :: ModLocation
mod_location = ModSummary -> ModLocation
ms_location ModSummary
mod_summary
    targetPath :: [Char]
targetPath   = ModLocation -> [Char]
Compat.ml_hie_file ModLocation
mod_location

writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile ShakeExtras
se HscEnv
hscEnv HiFileResult
tc =
  DynFlags -> Text -> IO () -> IO [FileDiagnostic]
handleGenerationErrors DynFlags
dflags Text
"interface write" forall a b. (a -> b) -> a -> b
$ do
    forall a. ShakeExtras -> [Char] -> ([Char] -> IO a) -> IO a
atomicFileWrite ShakeExtras
se [Char]
targetPath forall a b. (a -> b) -> a -> b
$ \[Char]
fp ->
      HscEnv -> [Char] -> ModIface -> IO ()
writeIfaceFile HscEnv
hscEnv [Char]
fp ModIface
modIface
  where
    modIface :: ModIface
modIface = HiFileResult -> ModIface
hirModIface HiFileResult
tc
    targetPath :: [Char]
targetPath = ModLocation -> [Char]
ml_hi_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ HiFileResult -> ModSummary
hirModSummary HiFileResult
tc
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv

handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
handleGenerationErrors :: DynFlags -> Text -> IO () -> IO [FileDiagnostic]
handleGenerationErrors DynFlags
dflags Text
source IO ()
action =
  IO ()
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [] forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches`
    [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
source DynFlags
dflags
    , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DiagnosticSeverity -> SrcSpan -> [Char] -> [FileDiagnostic]
diagFromString Text
source DiagnosticSeverity
DiagnosticSeverity_Error ([Char] -> SrcSpan
noSpan [Char]
"<internal>")
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
"Error during " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
source) forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @SomeException
    ]

handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
handleGenerationErrors' :: forall a.
DynFlags -> Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
handleGenerationErrors' DynFlags
dflags Text
source IO (Maybe a)
action =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([],) IO (Maybe a)
action forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches`
    [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
source DynFlags
dflags
    , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DiagnosticSeverity -> SrcSpan -> [Char] -> [FileDiagnostic]
diagFromString Text
source DiagnosticSeverity
DiagnosticSeverity_Error ([Char] -> SrcSpan
noSpan [Char]
"<internal>")
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
"Error during " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
source) forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @SomeException
    ]


-- Merge the HPTs, module graphs and FinderCaches
-- See Note [GhcSessionDeps] in Development.IDE.Core.Rules
-- Add the current ModSummary to the graph, along with the
-- HomeModInfo's of all direct dependencies (by induction hypothesis all
-- transitive dependencies will be contained in envs)
mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
mergeEnvs :: HscEnv
-> ModuleGraph
-> ModSummary
-> [HomeModInfo]
-> [HscEnv]
-> IO HscEnv
mergeEnvs HscEnv
env ModuleGraph
mg ModSummary
ms [HomeModInfo]
extraMods [HscEnv]
envs = do
#if MIN_VERSION_ghc(9,3,0)
    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
        ifr = InstalledFound (ms_location ms) im
        curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr
    newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
    return $! loadModulesHome extraMods $
      let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
      (hscUpdateHUG (const newHug) env){
          hsc_FC = newFinderCache,
          hsc_mod_graph = mg
      }

    where
        mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b
        mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }
        mergeUDFM = plusUDFM_C combineModules

        combineModules a b
          | HsSrcFile <- mi_hsc_src (hm_iface a) = a
          | otherwise = b

        -- Prefer non-boot files over non-boot files
        -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816
        -- if a boot file shadows over a non-boot file
        combineModuleLocations a@(InstalledFound ml _) _ | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a
        combineModuleLocations _ b = b

        concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache
        concatFC cur xs = do
          fcModules <- mapM (readIORef . fcModuleCache) xs
          fcFiles <- mapM (readIORef . fcFileCache) xs
          fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules
          fcFiles' <- newIORef $! Map.unions fcFiles
          pure $ FinderCache fcModules' fcFiles'

#else
    FinderCache
prevFinderCache <- [FinderCache] -> FinderCache
concatFC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. IORef a -> IO a
readIORef forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> IORef FinderCache
hsc_FC) [HscEnv]
envs
    let im :: InstalledModule
im  = forall unit. unit -> ModuleName -> GenModule unit
Compat.installedModule (Unit -> UnitId
toUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms) (forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms))
        ifr :: InstalledFindResult
ifr = ModLocation -> InstalledModule -> InstalledFindResult
InstalledFound (ModSummary -> ModLocation
ms_location ModSummary
ms) InstalledModule
im
    IORef FinderCache
newFinderCache <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$! forall a.
InstalledModuleEnv a
-> InstalledModule -> a -> InstalledModuleEnv a
Compat.extendInstalledModuleEnv FinderCache
prevFinderCache InstalledModule
im InstalledFindResult
ifr
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [HomeModInfo] -> HscEnv -> HscEnv
loadModulesHome [HomeModInfo]
extraMods forall a b. (a -> b) -> a -> b
$
      HscEnv
env{
          hsc_HPT :: HomePackageTable
hsc_HPT = forall (t :: * -> *) r a.
Foldable t =>
(r -> r -> r) -> r -> (a -> r) -> t a -> r
foldMapBy forall {key}.
UniqDFM key HomeModInfo
-> UniqDFM key HomeModInfo -> UniqDFM key HomeModInfo
mergeUDFM forall key elt. UniqDFM key elt
emptyUDFM HscEnv -> HomePackageTable
hsc_HPT [HscEnv]
envs,
          hsc_FC :: IORef FinderCache
hsc_FC = IORef FinderCache
newFinderCache,
          hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mg
      }

    where
        mergeUDFM :: UniqDFM key HomeModInfo
-> UniqDFM key HomeModInfo -> UniqDFM key HomeModInfo
mergeUDFM = forall elt key.
(elt -> elt -> elt)
-> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM_C HomeModInfo -> HomeModInfo -> HomeModInfo
combineModules
        combineModules :: HomeModInfo -> HomeModInfo -> HomeModInfo
combineModules HomeModInfo
a HomeModInfo
b
          | HscSource
HsSrcFile <- forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src (HomeModInfo -> ModIface
hm_iface HomeModInfo
a) = HomeModInfo
a
          | Bool
otherwise = HomeModInfo
b
    -- required because 'FinderCache':
    --  1) doesn't have a 'Monoid' instance,
    --  2) is abstract and doesn't export constructors
    -- To work around this, we coerce to the underlying type
    -- To remove this, I plan to upstream the missing Monoid instance
        concatFC :: [FinderCache] -> FinderCache
        concatFC :: [FinderCache] -> FinderCache
concatFC = forall a b. a -> b
unsafeCoerce (forall a. Monoid a => [a] -> a
mconcat @(Map InstalledModule InstalledFindResult))
#endif

withBootSuffix :: HscSource -> ModLocation -> ModLocation
withBootSuffix :: HscSource -> ModLocation -> ModLocation
withBootSuffix HscSource
HsBootFile = ModLocation -> ModLocation
addBootSuffixLocnOut
withBootSuffix HscSource
_          = forall a. a -> a
id

-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
--   Runs preprocessors as needed.
getModSummaryFromImports
  :: HscEnv
  -> FilePath
  -> UTCTime
  -> Maybe Util.StringBuffer
  -> ExceptT [FileDiagnostic] IO ModSummaryResult
-- modTime is only used in GHC < 9.4
getModSummaryFromImports :: HscEnv
-> [Char]
-> UTCTime
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO ModSummaryResult
getModSummaryFromImports HscEnv
env [Char]
fp UTCTime
_modTime Maybe StringBuffer
mContents = do
-- src_hash is only used in GHC >= 9.4
    (StringBuffer
contents, [[Char]]
opts, HscEnv
ppEnv, Fingerprint
_src_hash) <- HscEnv
-> [Char]
-> Maybe StringBuffer
-> ExceptT
     [FileDiagnostic] IO (StringBuffer, [[Char]], HscEnv, Fingerprint)
preprocessor HscEnv
env [Char]
fp Maybe StringBuffer
mContents

    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
ppEnv

    -- The warns will hopefully be reported when we actually parse the module
    ([FileDiagnostic]
_warns, L SrcSpan
main_loc HsModule
hsmod) <- forall (m :: * -> *).
Monad m =>
DynFlags
-> [Char]
-> StringBuffer
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
parseHeader DynFlags
dflags [Char]
fp StringBuffer
contents

    -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports
    let mb_mod :: Maybe (GenLocated SrcSpanAnnA ModuleName)
mb_mod = HsModule -> Maybe (GenLocated SrcSpanAnnA ModuleName)
hsmodName HsModule
hsmod
        imps :: [LImportDecl GhcPs]
imps = HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
hsmod

        mod :: ModuleName
mod = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated SrcSpanAnnA ModuleName)
mb_mod forall a. Maybe a -> a -> a
`Util.orElse` ModuleName
mAIN_NAME

        ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> IsBootInterface
ideclSourceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
imps

        -- GHC.Prim doesn't exist physically, so don't go looking for it.
        -- ghc_prim_imports is only used in GHC >= 9.4
        ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
_ghc_prim_imports)
          = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
                      [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls

        implicit_prelude :: Bool
implicit_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
dflags
        implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports ModuleName
mod SrcSpan
main_loc
                                         Bool
implicit_prelude [LImportDecl GhcPs]
imps


        convImport :: GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport (L l
_ ImportDecl pass
i) = (
#if !MIN_VERSION_ghc(9,3,0)
                               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs
#endif
                               (forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
i)
                             , forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
i)

        msrImports :: [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
msrImports = [LImportDecl GhcPs]
implicit_imports forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
imps

#if MIN_VERSION_ghc(9,3,0)
        rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv)
        rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
        srcImports = rn_imps $ map convImport src_idecls
        textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)
        ghc_prim_import = not (null _ghc_prim_imports)
#else
        srcImports :: [(Maybe FastString, Located ModuleName)]
srcImports = forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls
        textualImports :: [(Maybe FastString, Located ModuleName)]
textualImports = forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps)
#endif


    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> ()
rnf [(Maybe FastString, Located ModuleName)]
srcImports
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> ()
rnf [(Maybe FastString, Located ModuleName)]
textualImports


    ModLocation
modLoc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ if ModuleName
mod forall a. Eq a => a -> a -> Bool
== ModuleName
mAIN_NAME
        -- specially in tests it's common to have lots of nameless modules
        -- mkHomeModLocation will map them to the same hi/hie locations
        then DynFlags -> ModuleName -> [Char] -> IO ModLocation
mkHomeModLocation DynFlags
dflags ([Char] -> ModuleName
pathToModuleName [Char]
fp) [Char]
fp
        else DynFlags -> ModuleName -> [Char] -> IO ModLocation
mkHomeModLocation DynFlags
dflags ModuleName
mod [Char]
fp

    let modl :: Module
modl = HomeUnit -> ModuleName -> Module
mkHomeModule (HscEnv -> HomeUnit
hscHomeUnit HscEnv
ppEnv) ModuleName
mod
        sourceType :: HscSource
sourceType = if [Char]
"-boot" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char] -> [Char]
takeExtension [Char]
fp then HscSource
HsBootFile else HscSource
HsSrcFile
        msrModSummary2 :: ModSummary
msrModSummary2 =
            ModSummary
                { ms_mod :: Module
ms_mod          = Module
modl
                , ms_hie_date :: Maybe UTCTime
ms_hie_date     = forall a. Maybe a
Nothing
#if MIN_VERSION_ghc(9,3,0)
                , ms_dyn_obj_date    = Nothing
                , ms_ghc_prim_import = ghc_prim_import
                , ms_hs_hash      = _src_hash

#else
                , ms_hs_date :: UTCTime
ms_hs_date      = UTCTime
_modTime
#endif
                , ms_hsc_src :: HscSource
ms_hsc_src      = HscSource
sourceType
                -- The contents are used by the GetModSummary rule
                , ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf     = forall a. a -> Maybe a
Just StringBuffer
contents
                , ms_hspp_file :: [Char]
ms_hspp_file    = [Char]
fp
                , ms_hspp_opts :: DynFlags
ms_hspp_opts    = DynFlags
dflags
                , ms_iface_date :: Maybe UTCTime
ms_iface_date   = forall a. Maybe a
Nothing
                , ms_location :: ModLocation
ms_location     = HscSource -> ModLocation -> ModLocation
withBootSuffix HscSource
sourceType ModLocation
modLoc
                , ms_obj_date :: Maybe UTCTime
ms_obj_date     = forall a. Maybe a
Nothing
                , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod   = forall a. Maybe a
Nothing
                , ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps      = [(Maybe FastString, Located ModuleName)]
srcImports
                , ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_textual_imps = [(Maybe FastString, Located ModuleName)]
textualImports
                }

    Fingerprint
msrFingerprint <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [[Char]] -> ModSummary -> IO Fingerprint
computeFingerprint [[Char]]
opts ModSummary
msrModSummary2
    (ModSummary
msrModSummary, HscEnv
msrHscEnv) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> IO (ModSummary, HscEnv)
initPlugins HscEnv
ppEnv ModSummary
msrModSummary2
    forall (m :: * -> *) a. Monad m => a -> m a
return ModSummaryResult{[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
Fingerprint
HscEnv
ModSummary
msrHscEnv :: HscEnv
msrFingerprint :: Fingerprint
msrImports :: [LImportDecl GhcPs]
msrModSummary :: ModSummary
msrHscEnv :: HscEnv
msrModSummary :: ModSummary
msrFingerprint :: Fingerprint
msrImports :: [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
..}
    where
        -- Compute a fingerprint from the contents of `ModSummary`,
        -- eliding the timestamps, the preprocessed source and other non relevant fields
        computeFingerprint :: [[Char]] -> ModSummary -> IO Fingerprint
computeFingerprint [[Char]]
opts ModSummary{[Char]
[(Maybe FastString, Located ModuleName)]
Maybe UTCTime
Maybe HsParsedModule
Maybe StringBuffer
UTCTime
HscSource
ModLocation
DynFlags
Module
ms_hspp_buf :: Maybe StringBuffer
ms_hspp_opts :: DynFlags
ms_hspp_file :: [Char]
ms_parsed_mod :: Maybe HsParsedModule
ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_hie_date :: Maybe UTCTime
ms_iface_date :: Maybe UTCTime
ms_obj_date :: Maybe UTCTime
ms_hs_date :: UTCTime
ms_location :: ModLocation
ms_hsc_src :: HscSource
ms_mod :: Module
ms_textual_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_srcimps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_parsed_mod :: ModSummary -> Maybe HsParsedModule
ms_obj_date :: ModSummary -> Maybe UTCTime
ms_iface_date :: ModSummary -> Maybe UTCTime
ms_hspp_file :: ModSummary -> [Char]
ms_hspp_buf :: ModSummary -> Maybe StringBuffer
ms_hsc_src :: ModSummary -> HscSource
ms_hs_date :: ModSummary -> UTCTime
ms_hie_date :: ModSummary -> Maybe UTCTime
ms_mod :: ModSummary -> Module
ms_location :: ModSummary -> ModLocation
ms_hspp_opts :: ModSummary -> DynFlags
..} = do
            Fingerprint
fingerPrintImports <- Put -> IO Fingerprint
fingerprintFromPut forall a b. (a -> b) -> a -> b
$ do
                  forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ FastString -> Int
Util.uniq forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
moduleNameFS forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
ms_mod
                  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Maybe FastString, Located ModuleName)]
ms_srcimps forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, Located ModuleName)]
ms_textual_imps) forall a b. (a -> b) -> a -> b
$ \(Maybe FastString
mb_p, Located ModuleName
m) -> do
                    forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ FastString -> Int
Util.uniq forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
moduleNameFS forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc Located ModuleName
m
#if MIN_VERSION_ghc(9,3,0)
                    case mb_p of
                      G.NoPkgQual -> pure ()
                      G.ThisPkg uid  -> put $ getKey $ getUnique uid
                      G.OtherPkg uid -> put $ getKey $ getUnique uid
#else
                    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe FastString
mb_p forall a b. (a -> b) -> a -> b
$ forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Int
Util.uniq
#endif
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Fingerprint] -> Fingerprint
Util.fingerprintFingerprints forall a b. (a -> b) -> a -> b
$
                    [ [Char] -> Fingerprint
Util.fingerprintString [Char]
fp
                    , Fingerprint
fingerPrintImports
                    ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Fingerprint
Util.fingerprintString [[Char]]
opts


-- | Parse only the module header
parseHeader
       :: Monad m
       => DynFlags -- ^ flags to use
       -> FilePath  -- ^ the filename (for source locations)
       -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
#if MIN_VERSION_ghc(9,5,0)
       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))
#else
       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule))
#endif
parseHeader :: forall (m :: * -> *).
Monad m =>
DynFlags
-> [Char]
-> StringBuffer
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
parseHeader DynFlags
dflags [Char]
filename StringBuffer
contents = do
   let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
Util.mkFastString [Char]
filename) Int
1 Int
1
   case forall a. P a -> PState -> ParseResult a
unP P ParsedSource
Compat.parseHeader (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
contents RealSrcLoc
loc) of
     PFailedWithErrorMessages DynFlags -> Bag (MsgEnvelope DecoratedSDoc)
msgs ->
        forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags forall a b. (a -> b) -> a -> b
$ DynFlags -> Bag (MsgEnvelope DecoratedSDoc)
msgs DynFlags
dflags
     POk PState
pst ParsedSource
rdr_module -> do
        let (Bag (MsgEnvelope DecoratedSDoc)
warns, Bag (MsgEnvelope DecoratedSDoc)
errs) = (Bag (MsgEnvelope DecoratedSDoc), Bag (MsgEnvelope DecoratedSDoc))
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
renderMessages forall a b. (a -> b) -> a -> b
$ PState
-> DynFlags
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
getPsMessages PState
pst DynFlags
dflags

        -- Just because we got a `POk`, it doesn't mean there
        -- weren't errors! To clarify, the GHC parser
        -- distinguishes between fatal and non-fatal
        -- errors. Non-fatal errors are the sort that don't
        -- prevent parsing from continuing (that is, a parse
        -- tree can still be produced despite the error so that
        -- further errors/warnings can be collected). Fatal
        -- errors are those from which a parse tree just can't
        -- be produced.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag (MsgEnvelope DecoratedSDoc)
errs) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags Bag (MsgEnvelope DecoratedSDoc)
errs

        let warnings :: [FileDiagnostic]
warnings = Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags Bag (MsgEnvelope DecoratedSDoc)
warns
        forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
warnings, ParsedSource
rdr_module)

-- | Given a buffer, flags, and file path, produce a
-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
-- ModSummary must contain the (preprocessed) contents of the buffer
parseFileContents
       :: HscEnv
       -> (GHC.ParsedSource -> IdePreprocessedSource)
       -> FilePath  -- ^ the filename (for source locations)
       -> ModSummary
       -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
parseFileContents :: HscEnv
-> (ParsedSource -> IdePreprocessedSource)
-> [Char]
-> ModSummary
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
parseFileContents HscEnv
env ParsedSource -> IdePreprocessedSource
customPreprocessor [Char]
filename ModSummary
ms = do
   let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
Util.mkFastString [Char]
filename) Int
1 Int
1
       dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
       contents :: StringBuffer
contents = forall a. (?callStack::CallStack) => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ ModSummary -> Maybe StringBuffer
ms_hspp_buf ModSummary
ms
   case forall a. P a -> PState -> ParseResult a
unP P ParsedSource
Compat.parseModule (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
contents RealSrcLoc
loc) of
     PFailedWithErrorMessages DynFlags -> Bag (MsgEnvelope DecoratedSDoc)
msgs -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags forall a b. (a -> b) -> a -> b
$ DynFlags -> Bag (MsgEnvelope DecoratedSDoc)
msgs DynFlags
dflags
     POk PState
pst ParsedSource
rdr_module ->
         let
             hpm_annotations :: ()
hpm_annotations = PState -> ()
mkApiAnns PState
pst
             psMessages :: (Bag (MsgEnvelope DecoratedSDoc), Bag (MsgEnvelope DecoratedSDoc))
psMessages = PState
-> DynFlags
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
getPsMessages PState
pst DynFlags
dflags
         in
           do
               let IdePreprocessedSource [(SrcSpan, [Char])]
preproc_warns [(SrcSpan, [Char])]
errs ParsedSource
parsed = ParsedSource -> IdePreprocessedSource
customPreprocessor ParsedSource
rdr_module

               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SrcSpan, [Char])]
errs) forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ Text
-> DiagnosticSeverity -> [(SrcSpan, [Char])] -> [FileDiagnostic]
diagFromStrings Text
sourceParser DiagnosticSeverity
DiagnosticSeverity_Error [(SrcSpan, [Char])]
errs

               let preproc_warnings :: [FileDiagnostic]
preproc_warnings = Text
-> DiagnosticSeverity -> [(SrcSpan, [Char])] -> [FileDiagnostic]
diagFromStrings Text
sourceParser DiagnosticSeverity
DiagnosticSeverity_Warning [(SrcSpan, [Char])]
preproc_warns
               (ParsedSource
parsed', (Bag (MsgEnvelope DecoratedSDoc), Bag (MsgEnvelope DecoratedSDoc))
msgs) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> DynFlags
-> ModSummary
-> ()
-> ParsedSource
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
-> IO
     (ParsedSource,
      (Bag (MsgEnvelope DecoratedSDoc), Bag (MsgEnvelope DecoratedSDoc)))
applyPluginsParsedResultAction HscEnv
env DynFlags
dflags ModSummary
ms ()
hpm_annotations ParsedSource
parsed (Bag (MsgEnvelope DecoratedSDoc), Bag (MsgEnvelope DecoratedSDoc))
psMessages
               let (Bag (MsgEnvelope DecoratedSDoc)
warns, Bag (MsgEnvelope DecoratedSDoc)
errors) = (Bag (MsgEnvelope DecoratedSDoc), Bag (MsgEnvelope DecoratedSDoc))
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
renderMessages (Bag (MsgEnvelope DecoratedSDoc), Bag (MsgEnvelope DecoratedSDoc))
msgs

               -- Just because we got a `POk`, it doesn't mean there
               -- weren't errors! To clarify, the GHC parser
               -- distinguishes between fatal and non-fatal
               -- errors. Non-fatal errors are the sort that don't
               -- prevent parsing from continuing (that is, a parse
               -- tree can still be produced despite the error so that
               -- further errors/warnings can be collected). Fatal
               -- errors are those from which a parse tree just can't
               -- be produced.
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag (MsgEnvelope DecoratedSDoc)
errors) forall a b. (a -> b) -> a -> b
$
                 forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags Bag (MsgEnvelope DecoratedSDoc)
errors


               -- To get the list of extra source files, we take the list
               -- that the parser gave us,
               --   - eliminate files beginning with '<'.  gcc likes to use
               --     pseudo-filenames like "<built-in>" and "<command-line>"
               --   - normalise them (eliminate differences between ./f and f)
               --   - filter out the preprocessed source file
               --   - filter out anything beginning with tmpdir
               --   - remove duplicates
               --   - filter out the .hs/.lhs source filename if we have one
               --
               let n_hspp :: [Char]
n_hspp  = [Char] -> [Char]
normalise [Char]
filename
#if MIN_VERSION_ghc(9,3,0)
                   TempDir tmp_dir = tmpDir dflags
#else
                   tmp_dir :: [Char]
tmp_dir = DynFlags -> [Char]
tmpDir DynFlags
dflags
#endif
                   srcs0 :: [[Char]]
srcs0 = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
tmp_dir forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
                                  forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= [Char]
n_hspp)
                                  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
normalise
                                  forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"<")
                                  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FastString -> [Char]
Util.unpackFS
                                  forall a b. (a -> b) -> a -> b
$ PState -> [FastString]
srcfiles PState
pst
                   srcs1 :: [[Char]]
srcs1 = case ModLocation -> Maybe [Char]
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms) of
                             Just [Char]
f  -> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= [Char] -> [Char]
normalise [Char]
f) [[Char]]
srcs0
                             Maybe [Char]
Nothing -> [[Char]]
srcs0

               -- sometimes we see source files from earlier
               -- preprocessing stages that cannot be found, so just
               -- filter them out:
               [[Char]]
srcs2 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist [[Char]]
srcs1

               let pm :: ParsedModule
pm = ModSummary -> ParsedSource -> [[Char]] -> () -> ParsedModule
ParsedModule ModSummary
ms ParsedSource
parsed' [[Char]]
srcs2 ()
hpm_annotations
                   warnings :: [FileDiagnostic]
warnings = Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags Bag (MsgEnvelope DecoratedSDoc)
warns
               forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
warnings forall a. [a] -> [a] -> [a]
++ [FileDiagnostic]
preproc_warnings, ParsedModule
pm)

loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
loadHieFile :: NameCacheUpdater -> [Char] -> IO HieFile
loadHieFile NameCacheUpdater
ncu [Char]
f = do
  HieFileResult -> HieFile
GHC.hie_file_result forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameCacheUpdater -> [Char] -> IO HieFileResult
GHC.readHieFile NameCacheUpdater
ncu [Char]
f


{- Note [Recompilation avoidance in the presence of TH]

Most versions of GHC we currently support don't have a working implementation of
code unloading for object code, and no version of GHC supports this on certain
platforms like Windows. This makes it completely infeasible for interactive use,
as symbols from previous compiles will shadow over all future compiles.

This means that we need to use bytecode when generating code for Template
Haskell. Unfortunately, we can't serialize bytecode, so we will always need
to recompile when the IDE starts. However, we can put in place a much tighter
recompilation avoidance scheme for subsequent compiles:

1. If the source file changes, then we always need to recompile
   a. For files of interest, we will get explicit `textDocument/change` events
   that will let us invalidate our build products
   b. For files we read from disk, we can detect source file changes by
   comparing the `mtime` of the source file with the build product (.hi/.o) file
   on disk.
2. If GHC's recompilation avoidance scheme based on interface file hashes says
   that we need to recompile, the we need to recompile.
3. If the file in question requires code generation then, we need to recompile
   if we don't have the appropriate kind of build products.
   a. If we already have the build products in memory, and the conditions 1 and
   2 above hold, then we don't need to recompile
   b. If we are generating object code, then we can also search for it on
   disk and ensure it is up to date. Notably, we did _not_ previously re-use
   old bytecode from memory when `hls-graph`/`shake` decided to rebuild the
   `HiFileResult` for some reason

4. If the file in question used Template Haskell on the previous compile, then
we need to recompile if any `Linkable` in its transitive closure changed. This
sounds bad, but it is possible to make some improvements. In particular, we only
need to recompile if any of the `Linkable`s actually used during the previous
compile change.

How can we tell if a `Linkable` was actually used while running some TH?

GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as
it is being compiled and linked. We can inspect the bytecode to see which
`Linkable` dependencies it requires, and record this for use in
recompilation checking.
We record all the home package modules of the free names that occur in the
bytecode. The `Linkable`s required are then the transitive closure of these
modules in the home-package environment. This is the same scheme as used by
GHC to find the correct things to link in before running bytecode.

This works fine if we already have previous build products in memory, but
what if we are reading an interface from disk? Well, we can smuggle in the
necessary information (linkable `Module`s required as well as the time they
were generated) using `Annotation`s, which provide a somewhat general purpose
way to serialise arbitrary information along with interface files.

Then when deciding whether to recompile, we need to check that the versions
(i.e. hashes) of the linkables used during a previous compile match whatever is
currently in the HPT.

As we always generate Linkables from core files, we use the core file hash
as a (hopefully) deterministic measure of whether the Linkable has changed.
This is better than using the object file hash (if we have one) because object
file generation is not deterministic.
-}

data RecompilationInfo m
  = RecompilationInfo
  { forall (m :: * -> *). RecompilationInfo m -> FileVersion
source_version :: FileVersion
  , forall (m :: * -> *).
RecompilationInfo m -> Maybe (HiFileResult, FileVersion)
old_value   :: Maybe (HiFileResult, FileVersion)
  , forall (m :: * -> *).
RecompilationInfo m -> NormalizedFilePath -> m (Maybe FileVersion)
get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)
  , forall (m :: * -> *).
RecompilationInfo m -> [NormalizedFilePath] -> m [ByteString]
get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString]
  , forall (m :: * -> *).
RecompilationInfo m
-> Maybe LinkableType -> m (IdeResult HiFileResult)
regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface
  }

-- | Either a regular GHC linkable or a core file that
-- can be later turned into a proper linkable
data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile

instance NFData IdeLinkable where
  rnf :: IdeLinkable -> ()
rnf (GhcLinkable Linkable
lb)      = forall a. NFData a => a -> ()
rnf Linkable
lb
  rnf (CoreLinkable UTCTime
time CoreFile
_) = forall a. NFData a => a -> ()
rnf UTCTime
time

ml_core_file :: ModLocation -> FilePath
ml_core_file :: ModLocation -> [Char]
ml_core_file ModLocation
ml = ModLocation -> [Char]
ml_hi_file ModLocation
ml [Char] -> [Char] -> [Char]
<.> [Char]
"core"

-- | Returns an up-to-date module interface, regenerating if needed.
--   Assumes file exists.
--   Requires the 'HscEnv' to be set up with dependencies
-- See Note [Recompilation avoidance in the presence of TH]
loadInterface
  :: (MonadIO m, MonadMask m)
  => HscEnv
  -> ModSummary
  -> Maybe LinkableType
  -> RecompilationInfo m
  -> m ([FileDiagnostic], Maybe HiFileResult)
loadInterface :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
HscEnv
-> ModSummary
-> Maybe LinkableType
-> RecompilationInfo m
-> m (IdeResult HiFileResult)
loadInterface HscEnv
session ModSummary
ms Maybe LinkableType
linkableNeeded RecompilationInfo{Maybe (HiFileResult, FileVersion)
FileVersion
[NormalizedFilePath] -> m [ByteString]
Maybe LinkableType -> m (IdeResult HiFileResult)
NormalizedFilePath -> m (Maybe FileVersion)
regenerate :: Maybe LinkableType -> m (IdeResult HiFileResult)
get_linkable_hashes :: [NormalizedFilePath] -> m [ByteString]
get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)
old_value :: Maybe (HiFileResult, FileVersion)
source_version :: FileVersion
regenerate :: forall (m :: * -> *).
RecompilationInfo m
-> Maybe LinkableType -> m (IdeResult HiFileResult)
get_linkable_hashes :: forall (m :: * -> *).
RecompilationInfo m -> [NormalizedFilePath] -> m [ByteString]
get_file_version :: forall (m :: * -> *).
RecompilationInfo m -> NormalizedFilePath -> m (Maybe FileVersion)
old_value :: forall (m :: * -> *).
RecompilationInfo m -> Maybe (HiFileResult, FileVersion)
source_version :: forall (m :: * -> *). RecompilationInfo m -> FileVersion
..} = do
    let sessionWithMsDynFlags :: HscEnv
sessionWithMsDynFlags = DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
session
        mb_old_iface :: Maybe ModIface
mb_old_iface = HiFileResult -> ModIface
hirModIface forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HiFileResult, FileVersion)
old_value
        mb_old_version :: Maybe FileVersion
mb_old_version = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HiFileResult, FileVersion)
old_value

        core_file :: [Char]
core_file = ModLocation -> [Char]
ml_core_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
        iface_file :: [Char]
iface_file = ModLocation -> [Char]
ml_hi_file (ModSummary -> ModLocation
ms_location ModSummary
ms)

        !mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
ms

    Maybe FileVersion
mb_dest_version <- case Maybe FileVersion
mb_old_version of
      Just FileVersion
ver -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FileVersion
ver
      Maybe FileVersion
Nothing  -> NormalizedFilePath -> m (Maybe FileVersion)
get_file_version ([Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
iface_file)

    -- The source is modified if it is newer than the destination (iface file)
    -- A more precise check for the core file is performed later
    let _sourceMod :: SourceModified
_sourceMod = case Maybe FileVersion
mb_dest_version of -- sourceMod is only used in GHC < 9.4
          Maybe FileVersion
Nothing -> SourceModified
SourceModified -- destination file doesn't exist, assume modified source
          Just FileVersion
dest_version
            | FileVersion
source_version forall a. Ord a => a -> a -> Bool
<= FileVersion
dest_version -> SourceModified
SourceUnmodified
            | Bool
otherwise -> SourceModified
SourceModified

    -- old_iface is only used in GHC >= 9.4
    Maybe ModIface
_old_iface <- case Maybe ModIface
mb_old_iface of
      Just ModIface
iface -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ModIface
iface)
      Maybe ModIface
Nothing -> do
        -- ncu and read_dflags are only used in GHC >= 9.4
        let _ncu :: IORef NameCache
_ncu = HscEnv -> IORef NameCache
hsc_NC HscEnv
sessionWithMsDynFlags
            _read_dflags :: DynFlags
_read_dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
sessionWithMsDynFlags
#if MIN_VERSION_ghc(9,3,0)
        read_result <- liftIO $ readIface _read_dflags _ncu mod iface_file
#else
        MaybeErr SDoc ModIface
read_result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck ([Char] -> SDoc
text [Char]
"readIface") HscEnv
sessionWithMsDynFlags
                              forall a b. (a -> b) -> a -> b
$ forall gbl lcl.
Module -> [Char] -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)
readIface Module
mod [Char]
iface_file
#endif
        case MaybeErr SDoc ModIface
read_result of
          Util.Failed{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          -- important to call `shareUsages` here before checkOldIface
          -- consults `mi_usages`
          Util.Succeeded ModIface
iface -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ModIface -> ModIface
shareUsages ModIface
iface)

    -- If mb_old_iface is nothing then checkOldIface will load it for us
    -- given that the source is unmodified
    (RecompileRequired
recomp_iface_reqd, Maybe ModIface
mb_checked_iface)
#if MIN_VERSION_ghc(9,3,0)
      <- liftIO $ checkOldIface sessionWithMsDynFlags ms _old_iface >>= \case
        UpToDateItem x -> pure (UpToDate, Just x)
        OutOfDateItem reason x -> pure (NeedsRecompile reason, x)
#else
      <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface HscEnv
sessionWithMsDynFlags ModSummary
ms SourceModified
_sourceMod Maybe ModIface
mb_old_iface
#endif

    let do_regenerate :: RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate RecompileRequired
_reason = forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[Char] -> (([Char] -> [Char] -> m ()) -> m a) -> m a
withTrace [Char]
"regenerate interface" forall a b. (a -> b) -> a -> b
$ \[Char] -> [Char] -> m ()
setTag -> do
          [Char] -> [Char] -> m ()
setTag [Char]
"Module" forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
moduleNameString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod
          [Char] -> [Char] -> m ()
setTag [Char]
"Reason" forall a b. (a -> b) -> a -> b
$ RecompileRequired -> [Char]
showReason RecompileRequired
_reason
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
traceMarkerIO forall a b. (a -> b) -> a -> b
$ [Char]
"regenerate interface " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ModuleName -> [Char]
moduleNameString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod, RecompileRequired -> [Char]
showReason RecompileRequired
_reason)
          Maybe LinkableType -> m (IdeResult HiFileResult)
regenerate Maybe LinkableType
linkableNeeded

    case (Maybe ModIface
mb_checked_iface, RecompileRequired
recomp_iface_reqd) of
      (Just ModIface
iface, RecompileRequired
UpToDate) -> do
             ModDetails
details <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModIface -> IO ModDetails
mkDetailsFromIface HscEnv
sessionWithMsDynFlags ModIface
iface
             -- parse the runtime dependencies from the annotations
             let runtime_deps :: ModuleEnv ByteString
runtime_deps
                   | Bool -> Bool
not (forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th ModIface
iface) = forall a. ModuleEnv a
emptyModuleEnv
                   | Bool
otherwise = [Annotation] -> ModuleEnv ByteString
parseRuntimeDeps (ModDetails -> [Annotation]
md_anns ModDetails
details)
             -- Peform the fine grained recompilation check for TH
             Maybe RecompileRequired
maybe_recomp <- forall (m :: * -> *).
MonadIO m =>
HscEnv
-> ([NormalizedFilePath] -> m [ByteString])
-> ModuleEnv ByteString
-> m (Maybe RecompileRequired)
checkLinkableDependencies HscEnv
session [NormalizedFilePath] -> m [ByteString]
get_linkable_hashes ModuleEnv ByteString
runtime_deps
             case Maybe RecompileRequired
maybe_recomp of
               Just RecompileRequired
msg -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate RecompileRequired
msg
               Maybe RecompileRequired
Nothing
                 | forall a. Maybe a -> Bool
isJust Maybe LinkableType
linkableNeeded -> m (IdeResult HiFileResult) -> m (IdeResult HiFileResult)
handleErrs forall a b. (a -> b) -> a -> b
$ do
                   (coreFile :: CoreFile
coreFile@CoreFile{Fingerprint
cf_iface_hash :: CoreFile -> Fingerprint
cf_iface_hash :: Fingerprint
cf_iface_hash}, Fingerprint
core_hash) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                     NameCacheUpdater -> [Char] -> IO (CoreFile, Fingerprint)
readBinCoreFile (IORef NameCache -> NameCacheUpdater
mkUpdater forall a b. (a -> b) -> a -> b
$ HscEnv -> IORef NameCache
hsc_NC HscEnv
session) [Char]
core_file
                   if Fingerprint
cf_iface_hash forall a. Eq a => a -> a -> Bool
== ModIface -> Fingerprint
getModuleHash ModIface
iface
                   then forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModSummary
-> ModIface
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface
iface ModDetails
details ModuleEnv ByteString
runtime_deps (forall a. a -> Maybe a
Just (CoreFile
coreFile, Fingerprint -> ByteString
fingerprintToBS Fingerprint
core_hash)))
                   else RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate ([Char] -> RecompileRequired
recompBecause [Char]
"Core file out of date (doesn't match iface hash)")
                 | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModSummary
-> ModIface
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface
iface ModDetails
details ModuleEnv ByteString
runtime_deps forall a. Maybe a
Nothing)
                 where handleErrs :: m (IdeResult HiFileResult) -> m (IdeResult HiFileResult)
handleErrs = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
catches
                         [forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \(IOException
e :: IOException) -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate ([Char] -> RecompileRequired
recompBecause forall a b. (a -> b) -> a -> b
$ [Char]
"Reading core file failed (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show IOException
e forall a. [a] -> [a] -> [a]
++ [Char]
")")
                         ,forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \(GhcException
e :: GhcException) -> case GhcException
e of
                            Signal Int
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw GhcException
e
                            Panic [Char]
_  -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw GhcException
e
                            GhcException
_        -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate ([Char] -> RecompileRequired
recompBecause forall a b. (a -> b) -> a -> b
$ [Char]
"Reading core file failed (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show GhcException
e forall a. [a] -> [a] -> [a]
++ [Char]
")")
                         ]
      (Maybe ModIface
_, RecompileRequired
_reason) -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate RecompileRequired
_reason

-- | Find the runtime dependencies by looking at the annotations
-- serialized in the iface
-- The bytestrings are the hashes of the core files for modules we
-- required to run the TH splices in the given module.
-- See Note [Recompilation avoidance in the presence of TH]
parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString
parseRuntimeDeps :: [Annotation] -> ModuleEnv ByteString
parseRuntimeDeps [Annotation]
anns = forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Annotation -> Maybe (Module, ByteString)
go [Annotation]
anns
  where
    go :: Annotation -> Maybe (Module, ByteString)
go (Annotation (ModuleTarget Module
mod) Serialized
payload)
      | Just ByteString
bs <- forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized [Word8] -> ByteString
BS.pack Serialized
payload
      = forall a. a -> Maybe a
Just (Module
mod, ByteString
bs)
    go Annotation
_ = forall a. Maybe a
Nothing

-- | checkLinkableDependencies compares the core files in the build graph to
-- the runtime dependencies of the module, to check if any of them are out of date
-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
-- See Note [Recompilation avoidance in the presence of TH]
checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
checkLinkableDependencies :: forall (m :: * -> *).
MonadIO m =>
HscEnv
-> ([NormalizedFilePath] -> m [ByteString])
-> ModuleEnv ByteString
-> m (Maybe RecompileRequired)
checkLinkableDependencies HscEnv
hsc_env [NormalizedFilePath] -> m [ByteString]
get_linkable_hashes ModuleEnv ByteString
runtime_deps = do
#if MIN_VERSION_ghc(9,3,0)
  moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)
#else
  FinderCache
moduleLocs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (HscEnv -> IORef FinderCache
hsc_FC HscEnv
hsc_env)
#endif
  let go :: (Module, ByteString) -> Maybe (NormalizedFilePath, ByteString)
go (Module
mod, ByteString
hash) = do
        InstalledFindResult
ifr <- forall a. InstalledModuleEnv a -> InstalledModule -> Maybe a
lookupInstalledModuleEnv FinderCache
moduleLocs forall a b. (a -> b) -> a -> b
$ forall unit. unit -> ModuleName -> GenModule unit
Compat.installedModule (Unit -> UnitId
toUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit Module
mod) (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
        case InstalledFindResult
ifr of
          InstalledFound ModLocation
loc InstalledModule
_ -> do
            [Char]
hs <- ModLocation -> Maybe [Char]
ml_hs_file ModLocation
loc
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
hs,ByteString
hash)
          InstalledFindResult
_ -> forall a. Maybe a
Nothing
      hs_files :: Maybe [(NormalizedFilePath, ByteString)]
hs_files = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module, ByteString) -> Maybe (NormalizedFilePath, ByteString)
go (forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ModuleEnv ByteString
runtime_deps)
  case Maybe [(NormalizedFilePath, ByteString)]
hs_files of
    Maybe [(NormalizedFilePath, ByteString)]
Nothing -> forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"invalid module graph"
    Just [(NormalizedFilePath, ByteString)]
fs -> do
      [ByteString]
store_hashes <- [NormalizedFilePath] -> m [ByteString]
get_linkable_hashes (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(NormalizedFilePath, ByteString)]
fs)
      let out_of_date :: [NormalizedFilePath]
out_of_date = [NormalizedFilePath
core_file | ((NormalizedFilePath
core_file, ByteString
expected_hash), ByteString
actual_hash) <- forall a b. [a] -> [b] -> [(a, b)]
zip [(NormalizedFilePath, ByteString)]
fs [ByteString]
store_hashes, ByteString
expected_hash forall a. Eq a => a -> a -> Bool
/= ByteString
actual_hash]
      case [NormalizedFilePath]
out_of_date of
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        [NormalizedFilePath]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> RecompileRequired
recompBecause
              forall a b. (a -> b) -> a -> b
$ [Char]
"out of date runtime dependencies: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [NormalizedFilePath]
out_of_date)

recompBecause :: String -> RecompileRequired
recompBecause :: [Char] -> RecompileRequired
recompBecause =
#if MIN_VERSION_ghc(9,3,0)
                NeedsRecompile .
#endif
                [Char] -> RecompileRequired
RecompBecause
#if MIN_VERSION_ghc(9,3,0)
              . CustomReason
#endif

#if MIN_VERSION_ghc(9,3,0)
data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show)
#endif

showReason :: RecompileRequired -> String
showReason :: RecompileRequired -> [Char]
showReason RecompileRequired
UpToDate          = [Char]
"UpToDate"
#if MIN_VERSION_ghc(9,3,0)
showReason (NeedsRecompile MustCompile)    = "MustCompile"
showReason (NeedsRecompile s) = printWithoutUniques s
#else
showReason RecompileRequired
MustCompile       = [Char]
"MustCompile"
showReason (RecompBecause [Char]
s) = [Char]
s
#endif

mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails
mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails
mkDetailsFromIface HscEnv
session ModIface
iface = do
  forall a. (a -> IO a) -> IO a
fixIO forall a b. (a -> b) -> a -> b
$ \ModDetails
details -> do
    let !hsc' :: HscEnv
hsc' = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (\HomePackageTable
hpt -> HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) (ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details Maybe Linkable
emptyHomeModInfoLinkable)) HscEnv
session
    forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc' (ModIface -> IfG ModDetails
typecheckIface ModIface
iface)

coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts HscEnv
session ModIface
iface ModDetails
details CoreFile
core_file = do
  let act :: HomePackageTable -> HomePackageTable
act HomePackageTable
hpt = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)
                             (ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details Maybe Linkable
emptyHomeModInfoLinkable)
      this_mod :: Module
this_mod = forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface
  IORef TypeEnv
types_var <- forall a. a -> IO (IORef a)
newIORef (ModDetails -> TypeEnv
md_types ModDetails
details)
  let hsc_env' :: HscEnv
hsc_env' = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT HomePackageTable -> HomePackageTable
act (HscEnv
session {
#if MIN_VERSION_ghc(9,3,0)
        hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
#else
        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = forall a. a -> Maybe a
Just (Module
this_mod, IORef TypeEnv
types_var)
#endif
        })
  CoreProgram
core_binds <- forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck ([Char] -> SDoc
text [Char]
"l") HscEnv
hsc_env' forall a b. (a -> b) -> a -> b
$ Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
typecheckCoreFile Module
this_mod IORef TypeEnv
types_var CoreFile
core_file
      -- Implicit binds aren't saved, so we need to regenerate them ourselves.
  let _implicit_binds :: CoreProgram
_implicit_binds = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> CoreProgram
getImplicitBinds [TyCon]
tyCons -- only used if GHC < 9.6
      tyCons :: [TyCon]
tyCons = TypeEnv -> [TyCon]
typeEnvTyCons (ModDetails -> TypeEnv
md_types ModDetails
details)
#if MIN_VERSION_ghc(9,5,0)
  -- In GHC 9.6, the implicit binds are tidied and part of core_binds
  pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False) Nothing []
#elif MIN_VERSION_ghc(9,3,0)
  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing []
#else
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Module
-> [TyCon]
-> CoreProgram
-> ForeignStubs
-> [(ForeignSrcLang, [Char])]
-> [UnitId]
-> HpcInfo
-> Maybe ModBreaks
-> [SptEntry]
-> CgGuts
CgGuts Module
this_mod [TyCon]
tyCons (CoreProgram
_implicit_binds forall a. [a] -> [a] -> [a]
++ CoreProgram
core_binds) ForeignStubs
NoStubs [] [] (Bool -> HpcInfo
emptyHpcInfo Bool
False) forall a. Maybe a
Nothing []
#endif

coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)
coreFileToLinkable :: LinkableType
-> HscEnv
-> ModSummary
-> ModIface
-> ModDetails
-> CoreFile
-> UTCTime
-> IO ([FileDiagnostic], Maybe HomeModInfo)
coreFileToLinkable LinkableType
linkableType HscEnv
session ModSummary
ms ModIface
iface ModDetails
details CoreFile
core_file UTCTime
t = do
  CgGuts
cgi_guts <- HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts HscEnv
session ModIface
iface ModDetails
details CoreFile
core_file
  ([FileDiagnostic]
warns, Maybe Linkable
lb) <- case LinkableType
linkableType of
    LinkableType
BCOLinkable    -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Linkable
emptyHomeModInfoLinkable Linkable -> Maybe Linkable
justBytecode) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreFileTime
-> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode (UTCTime -> CoreFileTime
CoreFileTime UTCTime
t) HscEnv
session ModSummary
ms CgGuts
cgi_guts
    LinkableType
ObjectLinkable -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Linkable
emptyHomeModInfoLinkable Linkable -> Maybe Linkable
justObjects) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode HscEnv
session ModSummary
ms CgGuts
cgi_guts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
warns, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details Maybe Linkable
lb) -- TODO wz1000 handle emptyHomeModInfoLinkable

-- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
--   The interactive paths create problems in ghc-lib builds
--- and leads to fun errors like "Cannot continue after interface file error".
getDocsBatch
  :: HscEnv
  -> [Name]
#if MIN_VERSION_ghc(9,3,0)
  -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
#else
  -> IO [Either String (Maybe HsDocString, IntMap HsDocString)]
#endif
getDocsBatch :: HscEnv
-> [Name]
-> IO [Either [Char] (Maybe HsDocString, IntMap HsDocString)]
getDocsBatch HscEnv
hsc_env [Name]
_names = do
    [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
res <- forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
_names forall a b. (a -> b) -> a -> b
$ \Name
name ->
        case Name -> Maybe Module
nameModule_maybe Name
name of
            Maybe Module
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Name -> GetDocsFailure
NameHasNoModule Name
name)
            Just Module
mod -> do
             ModIface {
#if MIN_VERSION_ghc(9,3,0)
                        mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr
                                      , docs_decls = dmap
                                      , docs_args = amap
                                      }
#else
                        mi_doc_hdr :: forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe HsDocString
mi_doc_hdr = Maybe HsDocString
mb_doc_hdr
                      , mi_decl_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> DeclDocMap
mi_decl_docs = DeclDocMap Map Name HsDocString
dmap
                      , mi_arg_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> ArgDocMap
mi_arg_docs = ArgDocMap Map Name (IntMap HsDocString)
amap
#endif
                      } <- forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface ([Char] -> SDoc
text [Char]
"getModuleInterface") Module
mod
#if MIN_VERSION_ghc(9,3,0)
             if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap
#else
             if forall a. Maybe a -> Bool
isNothing Maybe HsDocString
mb_doc_hdr Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map Name HsDocString
dmap Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Name (IntMap HsDocString)
amap
#endif
               then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Module -> Bool -> GetDocsFailure
NoDocsInIface Module
mod forall a b. (a -> b) -> a -> b
$ Name -> Bool
compiled Name
name))
               else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (
#if MIN_VERSION_ghc(9,3,0)
                                  lookupUniqMap dmap name,
#else
                                  forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name HsDocString
dmap ,
#endif
#if MIN_VERSION_ghc(9,3,0)
                                  lookupWithDefaultUniqMap amap mempty name))
#else
                                  forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty Name
name Map Name (IntMap HsDocString)
amap))
#endif
    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 (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Text
printOutputable) [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
res
  where
    compiled :: Name -> Bool
compiled Name
n =
      -- TODO: Find a more direct indicator.
      case Name -> SrcLoc
nameSrcLoc Name
n of
        RealSrcLoc {}   -> Bool
False
        UnhelpfulLoc {} -> Bool
True

-- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.
--   The interactive paths create problems in ghc-lib builds
--- and leads to fun errors like "Cannot continue after interface file error".
lookupName :: HscEnv
           -> Name
           -> IO (Maybe TyThing)
lookupName :: HscEnv -> Name -> IO (Maybe TyThing)
lookupName HscEnv
_ Name
name
  | Maybe Module
Nothing <- Name -> Maybe Module
nameModule_maybe Name
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
lookupName HscEnv
hsc_env Name
name = forall {m :: * -> *} {a}.
MonadCatch m =>
m (Maybe a) -> m (Maybe a)
exceptionHandle forall a b. (a -> b) -> a -> b
$ do
  Maybe TyThing
mb_thing <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name
  case Maybe TyThing
mb_thing of
    x :: Maybe TyThing
x@(Just TyThing
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TyThing
x
    Maybe TyThing
Nothing
      | x :: Maybe TyThing
x@(Just TyThing
thing) <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
name
      -> do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyThing -> Bool
needWiredInHomeIface TyThing
thing)
                 (forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (forall lcl. Name -> IfM lcl ()
loadWiredInHomeIface Name
name))
            forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TyThing
x
      | Bool
otherwise -> do
        MaybeErr SDoc TyThing
res <- forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall lcl. Name -> IfM lcl (MaybeErr SDoc TyThing)
importDecl Name
name
        case MaybeErr SDoc TyThing
res of
          Util.Succeeded TyThing
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just TyThing
x)
          MaybeErr SDoc TyThing
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
    exceptionHandle :: m (Maybe a) -> m (Maybe a)
exceptionHandle m (Maybe a)
x = m (Maybe a)
x forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOEnvFailure
_ :: IOEnvFailure) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

pathToModuleName :: FilePath -> ModuleName
pathToModuleName :: [Char] -> ModuleName
pathToModuleName = [Char] -> ModuleName
mkModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
rep
  where
      rep :: Char -> Char
rep Char
c | Char -> Bool
isPathSeparator Char
c = Char
'_'
      rep Char
':' = Char
'_'
      rep Char
c = Char
c

{- Note [Guidelines For Using CPP In GHCIDE Import Statements]
  GHCIDE's interface with GHC is extensive, and unfortunately, because we have
  to work with multiple versions of GHC, we have several files that need to use
  a lot of CPP. In order to simplify the CPP in the import section of every file
  we have a few specific guidelines for using CPP in these sections.

  - We don't want to nest CPP clauses, nor do we want to use else clauses. Both
  nesting and else clauses end up drastically complicating the code, and require
  significant mental stack to unwind.

  - CPP clauses should be placed at the end of the imports section. The clauses
  should be ordered by the GHC version they target from earlier to later versions,
  with negative if clauses coming before positive if clauses of the same 
  version. (If you think about which GHC version a clause activates for this 
  should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is
  a earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 
  and later). In addition there should be a space before and after each CPP
  clause.

  - In if clauses that use `&&` and depend on more than one statement, the 
  positive statement should come before the negative statement. In addition the
  clause should come after the single positive clause for that GHC version.

  - There shouldn't be multiple identical CPP statements. The use of odd or even 
  GHC numbers is identical, with the only preference being to use what is
  already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` 
  are functionally equivalent)
-}