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

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

-- | 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           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.Extra
import           Control.Monad.IO.Class
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.Maybe
import           Data.Proxy                        (Proxy (Proxy))
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, assert)
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.Protocol.Message     as LSP
import           Language.LSP.Protocol.Types       (DiagnosticTag (..))
import qualified Language.LSP.Protocol.Types       as LSP
import qualified Language.LSP.Server               as LSP
import           Prelude                           hiding (mod)
import           System.Directory
import           System.FilePath
import           System.IO.Extra                   (fixIO, newTempFileWithin)

import qualified GHC                               as G
import           GHC.Tc.Gen.Splice
import           GHC.Types.ForeignStubs
import           GHC.Types.HpcInfo
import           GHC.Types.TypeEnv

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

#if !MIN_VERSION_ghc(9,3,0)
import           Data.Map                          (Map)
import           GHC.Unit.Module.Graph             (ModuleGraph)
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.Core.Lint.Interactive
import           GHC.Driver.Config.CoreToStg.Prep
#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 -> FilePath -> ModSummary -> IO (IdeResult ParsedModule)
parseModule IdeOptions{Bool
Int
FilePath
[FilePath]
[Text]
Maybe FilePath
IO Bool
IO CheckParents
Action IdeGhcSession
ShakeOptions
IdePkgLocationOptions
ProgressReportingStyle
IdeTesting
IdeDefer
IdeReportProgress
OptHaddockParse
ParsedSource -> IdePreprocessedSource
Config -> DynFlagsModifications
forall a. Typeable a => a -> Bool
optPreprocessor :: ParsedSource -> IdePreprocessedSource
optGhcSession :: Action IdeGhcSession
optPkgLocationOpts :: IdePkgLocationOptions
optExtensions :: [FilePath]
optShakeProfiling :: Maybe FilePath
optTesting :: IdeTesting
optReportProgress :: IdeReportProgress
optMaxDirtyAge :: Int
optLanguageSyntax :: FilePath
optNewColonConvention :: Bool
optKeywords :: [Text]
optDefer :: IdeDefer
optCheckProject :: IO Bool
optCheckParents :: IO CheckParents
optHaddockParse :: OptHaddockParse
optModifyDynFlags :: Config -> DynFlagsModifications
optShakeOptions :: ShakeOptions
optSkipProgress :: forall a. Typeable a => a -> Bool
optProgressStyle :: ProgressReportingStyle
optRunSubset :: Bool
optVerifyCoreFile :: Bool
optPreprocessor :: IdeOptions -> ParsedSource -> IdePreprocessedSource
optGhcSession :: IdeOptions -> Action IdeGhcSession
optPkgLocationOpts :: IdeOptions -> IdePkgLocationOptions
optExtensions :: IdeOptions -> [FilePath]
optShakeProfiling :: IdeOptions -> Maybe FilePath
optTesting :: IdeOptions -> IdeTesting
optReportProgress :: IdeOptions -> IdeReportProgress
optMaxDirtyAge :: IdeOptions -> Int
optLanguageSyntax :: IdeOptions -> FilePath
optNewColonConvention :: IdeOptions -> Bool
optKeywords :: IdeOptions -> [Text]
optDefer :: IdeOptions -> IdeDefer
optCheckProject :: IdeOptions -> IO Bool
optCheckParents :: IdeOptions -> IO CheckParents
optHaddockParse :: IdeOptions -> OptHaddockParse
optModifyDynFlags :: IdeOptions -> Config -> DynFlagsModifications
optShakeOptions :: IdeOptions -> ShakeOptions
optSkipProgress :: IdeOptions -> forall a. Typeable a => a -> Bool
optProgressStyle :: IdeOptions -> ProgressReportingStyle
optRunSubset :: IdeOptions -> Bool
optVerifyCoreFile :: IdeOptions -> Bool
..} HscEnv
env FilePath
filename ModSummary
ms =
    (Either [FileDiagnostic] (IdeResult ParsedModule)
 -> IdeResult ParsedModule)
-> IO (Either [FileDiagnostic] (IdeResult ParsedModule))
-> IO (IdeResult ParsedModule)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FileDiagnostic] -> IdeResult ParsedModule)
-> (IdeResult ParsedModule -> IdeResult ParsedModule)
-> Either [FileDiagnostic] (IdeResult ParsedModule)
-> IdeResult ParsedModule
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, Maybe ParsedModule
forall a. Maybe a
Nothing) IdeResult ParsedModule -> IdeResult ParsedModule
forall a. a -> a
id) (IO (Either [FileDiagnostic] (IdeResult ParsedModule))
 -> IO (IdeResult ParsedModule))
-> IO (Either [FileDiagnostic] (IdeResult ParsedModule))
-> IO (IdeResult ParsedModule)
forall a b. (a -> b) -> a -> b
$
    ExceptT [FileDiagnostic] IO (IdeResult ParsedModule)
-> IO (Either [FileDiagnostic] (IdeResult ParsedModule))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [FileDiagnostic] IO (IdeResult ParsedModule)
 -> IO (Either [FileDiagnostic] (IdeResult ParsedModule)))
-> ExceptT [FileDiagnostic] IO (IdeResult ParsedModule)
-> IO (Either [FileDiagnostic] (IdeResult ParsedModule))
forall a b. (a -> b) -> a -> b
$ do
        ([FileDiagnostic]
diag, ParsedModule
modu) <- HscEnv
-> (ParsedSource -> IdePreprocessedSource)
-> FilePath
-> ModSummary
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
parseFileContents HscEnv
env ParsedSource -> IdePreprocessedSource
optPreprocessor FilePath
filename ModSummary
ms
        IdeResult ParsedModule
-> ExceptT [FileDiagnostic] IO (IdeResult ParsedModule)
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
diag, ParsedModule -> Maybe ParsedModule
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 -> Either [FileDiagnostic] [UnitId]
-> IO (Either [FileDiagnostic] [UnitId])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] [UnitId]
 -> IO (Either [FileDiagnostic] [UnitId]))
-> Either [FileDiagnostic] [UnitId]
-> IO (Either [FileDiagnostic] [UnitId])
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Either [FileDiagnostic] [UnitId]
forall a b. a -> Either a b
Left [NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
noFilePath) (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$
            FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"unknown package: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Unit -> FilePath
forall a. Show a => a -> FilePath
show Unit
pkg]
        Just UnitInfo
pkgInfo -> Either [FileDiagnostic] [UnitId]
-> IO (Either [FileDiagnostic] [UnitId])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] [UnitId]
 -> IO (Either [FileDiagnostic] [UnitId]))
-> Either [FileDiagnostic] [UnitId]
-> IO (Either [FileDiagnostic] [UnitId])
forall a b. (a -> b) -> a -> b
$ [UnitId] -> Either [FileDiagnostic] [UnitId]
forall a b. b -> Either a b
Right ([UnitId] -> Either [FileDiagnostic] [UnitId])
-> [UnitId] -> Either [FileDiagnostic] [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo 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 <- DynFlags
-> Text
-> IO (ModSummary, HscEnv)
-> IO (Either [FileDiagnostic] (ModSummary, HscEnv))
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 -> IdeResult TcModuleResult -> IO (IdeResult TcModuleResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
errs, Maybe TcModuleResult
forall a. Maybe a
Nothing)
          Right (ModSummary
modSummary', HscEnv
hscEnv) -> do
            ([(Maybe DiagnosticReason, FileDiagnostic)]
warnings, Either [FileDiagnostic] TcModuleResult
etcm) <- Text
-> ((HscEnv -> HscEnv)
    -> IO (Either [FileDiagnostic] TcModuleResult))
-> IO
     ([(Maybe DiagnosticReason, FileDiagnostic)],
      Either [FileDiagnostic] TcModuleResult)
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
withWarnings Text
sourceTypecheck (((HscEnv -> HscEnv)
  -> IO (Either [FileDiagnostic] TcModuleResult))
 -> IO
      ([(Maybe DiagnosticReason, FileDiagnostic)],
       Either [FileDiagnostic] TcModuleResult))
-> ((HscEnv -> HscEnv)
    -> IO (Either [FileDiagnostic] TcModuleResult))
-> IO
     ([(Maybe DiagnosticReason, FileDiagnostic)],
      Either [FileDiagnostic] TcModuleResult)
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 = hsc_dflags session}
                in
                  DynFlags
-> Text
-> IO TcModuleResult
-> IO (Either [FileDiagnostic] TcModuleResult)
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv) Text
sourceTypecheck (IO TcModuleResult -> IO (Either [FileDiagnostic] TcModuleResult))
-> IO TcModuleResult -> IO (Either [FileDiagnostic] TcModuleResult)
forall a b. (a -> b) -> a -> b
$ do
                    HscEnv -> TypecheckHelpers -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
session TypecheckHelpers
tc_helpers (ParsedModule -> IO TcModuleResult)
-> ParsedModule -> IO TcModuleResult
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedModule
demoteIfDefer ParsedModule
pm{pm_mod_summary = mod_summary''}
            let errorPipeline :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)
errorPipeline = (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer ((Maybe DiagnosticReason, FileDiagnostic)
 -> (Bool, FileDiagnostic))
-> ((Maybe DiagnosticReason, FileDiagnostic)
    -> (Maybe DiagnosticReason, FileDiagnostic))
-> (Maybe DiagnosticReason, FileDiagnostic)
-> (Bool, FileDiagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> (Maybe DiagnosticReason, FileDiagnostic)
-> (Maybe DiagnosticReason, FileDiagnostic)
hideDiag DynFlags
dflags ((Maybe DiagnosticReason, FileDiagnostic)
 -> (Maybe DiagnosticReason, FileDiagnostic))
-> ((Maybe DiagnosticReason, FileDiagnostic)
    -> (Maybe DiagnosticReason, FileDiagnostic))
-> (Maybe DiagnosticReason, FileDiagnostic)
-> (Maybe DiagnosticReason, FileDiagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe DiagnosticReason, FileDiagnostic)
-> (Maybe DiagnosticReason, FileDiagnostic)
tagDiag
                diags :: [(Bool, FileDiagnostic)]
diags = ((Maybe DiagnosticReason, FileDiagnostic)
 -> (Bool, FileDiagnostic))
-> [(Maybe DiagnosticReason, FileDiagnostic)]
-> [(Bool, FileDiagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)
errorPipeline [(Maybe DiagnosticReason, FileDiagnostic)]
warnings
                deferredError :: Bool
deferredError = ((Bool, FileDiagnostic) -> Bool)
-> [(Bool, FileDiagnostic)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool, FileDiagnostic) -> Bool
forall a b. (a, b) -> a
fst [(Bool, FileDiagnostic)]
diags
            case Either [FileDiagnostic] TcModuleResult
etcm of
              Left [FileDiagnostic]
errs -> IdeResult TcModuleResult -> IO (IdeResult TcModuleResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Bool, FileDiagnostic) -> FileDiagnostic)
-> [(Bool, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(Bool, FileDiagnostic)]
diags [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
forall a. [a] -> [a] -> [a]
++ [FileDiagnostic]
errs, Maybe TcModuleResult
forall a. Maybe a
Nothing)
              Right TcModuleResult
tcm -> IdeResult TcModuleResult -> IO (IdeResult TcModuleResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Bool, FileDiagnostic) -> FileDiagnostic)
-> [(Bool, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(Bool, FileDiagnostic)]
diags, TcModuleResult -> Maybe TcModuleResult
forall a. a -> Maybe a
Just (TcModuleResult -> Maybe TcModuleResult)
-> TcModuleResult -> Maybe TcModuleResult
forall a b. (a -> b) -> a -> b
$ TcModuleResult
tcm{tmrDeferredError = deferredError})
    where
        demoteIfDefer :: ParsedModule -> ParsedModule
demoteIfDefer = if Bool
defer then ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings else ParsedModule -> ParsedModule
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 :: TypecheckHelpers -> [NormalizedFilePath] -> IO [LinkableResult]
getLinkables :: [NormalizedFilePath] -> IO [LinkableResult]
..} HscEnv
env HscEnv -> IO a
k = do
  IORef Splices
splice_ref <- Splices -> IO (IORef Splices)
forall a. a -> IO (IORef a)
newIORef Splices
forall a. Monoid a => a
mempty
  IORef (ModuleEnv ByteString)
dep_ref <- ModuleEnv ByteString -> IO (IORef (ModuleEnv ByteString))
forall a. a -> IO (IORef a)
newIORef ModuleEnv ByteString
forall a. ModuleEnv a
emptyModuleEnv
  a
res <- HscEnv -> IO a
k (Hooks -> HscEnv -> HscEnv
hscSetHooks (IORef Splices -> Hooks -> Hooks
addSpliceHook IORef Splices
splice_ref (Hooks -> Hooks) -> (Hooks -> Hooks) -> Hooks -> Hooks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (ModuleEnv ByteString) -> Hooks -> Hooks
addLinkableDepHook IORef (ModuleEnv ByteString)
dep_ref (Hooks -> Hooks) -> Hooks -> Hooks
forall a b. (a -> b) -> a -> b
$ HscEnv -> Hooks
hsc_hooks HscEnv
env) HscEnv
env)
  Splices
splices <- IORef Splices -> IO Splices
forall a. IORef a -> IO a
readIORef IORef Splices
splice_ref
  ModuleEnv ByteString
needed_mods <- IORef (ModuleEnv ByteString) -> IO (ModuleEnv ByteString)
forall a. IORef a -> IO a
readIORef IORef (ModuleEnv ByteString)
dep_ref
  (a, Splices, ModuleEnv ByteString)
-> IO (a, Splices, ModuleEnv ByteString)
forall a. a -> IO a
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 = Just (compile_bco_hook 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, [Linkable], PkgsLoaded)
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 FilePath
ml_hs_file   = Maybe FilePath
forall a. Maybe a
Nothing,
                                        ml_hi_file :: FilePath
ml_hi_file   = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"hscCompileCoreExpr':ml_hi_file",
                                        ml_obj_file :: FilePath
ml_obj_file  = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"hscCompileCoreExpr':ml_obj_file",
#if MIN_VERSION_ghc(9,3,0)
                                        ml_dyn_obj_file :: FilePath
ml_dyn_obj_file = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"hscCompileCoreExpr':ml_dyn_obj_file",
                                        ml_dyn_hi_file :: FilePath
ml_dyn_hi_file  = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"hscCompileCoreExpr':ml_dyn_hi_file",
#endif
                                        ml_hie_file :: FilePath
ml_hie_file  = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"hscCompileCoreExpr':ml_hie_file"
                                        }
           ; let ictxt :: InteractiveContext
ictxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env

           ; (Id
binding_id, [CgStgTopBinding]
stg_expr, InfoTableProvMap
_, CollectedCCs
_) <-
               Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreExpr
-> IO (Id, [CgStgTopBinding], 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)
                               Bool
True -- for bytecode
#endif
                               (InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
                               ModLocation
iNTERACTIVELoc
                               CoreExpr
prepd_expr

             {- Convert to BCOs -}
           ; CompiledByteCode
bcos <- HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env
                       (InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
                       [CgStgTopBinding]
stg_expr
                       [] Maybe ModBreaks
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 Module
needed_mods = [Module] -> UniqSet Module
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [
#if MIN_VERSION_ghc(9,3,0)
                                           Module
mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids
#else
                                           moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same
#endif

                                         | Name
n <- (UnlinkedBCO -> [Name]) -> [UnlinkedBCO] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (UniqDSet Name -> [Name]
forall a. UniqDSet a -> [a]
uniqDSetToList (UniqDSet Name -> [Name])
-> (UnlinkedBCO -> UniqDSet Name) -> UnlinkedBCO -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnlinkedBCO -> UniqDSet Name
bcoFreeNames) ([UnlinkedBCO] -> [Name]) -> [UnlinkedBCO] -> [Name]
forall a b. (a -> b) -> a -> b
$ CompiledByteCode -> [UnlinkedBCO]
bc_bcos CompiledByteCode
bcos
                                         , Bool -> Bool
not (Name -> Bool
isWiredInName Name
n) -- Exclude wired-in names
                                         , Just Module
mod <- [Name -> Maybe Module
nameModule_maybe Name
n] -- Names from other modules
                                         , Module -> UnitId
moduleUnitId Module
mod UnitId -> [UnitId] -> Bool
forall a. Eq a => a -> [a] -> Bool
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)
                    ((UnitId, HomeUnitEnv) -> UnitId)
-> [(UnitId, HomeUnitEnv)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, HomeUnitEnv) -> UnitId
forall a b. (a, b) -> a
fst (HomeUnitGraph -> [(UnitId, HomeUnitEnv)]
hugElts (HomeUnitGraph -> [(UnitId, HomeUnitEnv)])
-> HomeUnitGraph -> [(UnitId, HomeUnitEnv)]
forall a b. (a -> b) -> a -> b
$ HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
#else
                    [homeUnitId_ dflags]
#endif
                 mods_transitive :: Set NodeKey
mods_transitive = HscEnv -> UniqSet Module -> Set NodeKey
getTransitiveMods HscEnv
hsc_env UniqSet Module
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)
                                         (NodeKey -> Maybe InstalledModule)
-> [NodeKey] -> [InstalledModule]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe InstalledModule
nodeKeyToInstalledModule ([NodeKey] -> [InstalledModule]) -> [NodeKey] -> [InstalledModule]
forall a b. (a -> b) -> a -> b
$ Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
mods_transitive
#else
                                        -- Non det OK as we will put it into maps later anyway
                                         map (Compat.installedModule (homeUnitId_ dflags)) $ nonDetEltsUniqSet mods_transitive
#endif

#if MIN_VERSION_ghc(9,3,0)
           ; FinderCacheState
moduleLocs <- IORef FinderCacheState -> IO FinderCacheState
forall a. IORef a -> IO a
readIORef (FinderCache -> IORef FinderCacheState
fcModuleCache (FinderCache -> IORef FinderCacheState)
-> FinderCache -> IORef FinderCacheState
forall a b. (a -> b) -> a -> b
$ HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env)
#else
           ; moduleLocs <- readIORef (hsc_FC hsc_env)
#endif
           ; [LinkableResult]
lbs <- [NormalizedFilePath] -> IO [LinkableResult]
getLinkables [FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
file
                                 | InstalledModule
installedMod <- [InstalledModule]
mods_transitive_list
                                 , let ifr :: InstalledFindResult
ifr = Maybe InstalledFindResult -> InstalledFindResult
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe InstalledFindResult -> InstalledFindResult)
-> Maybe InstalledFindResult -> InstalledFindResult
forall a b. (a -> b) -> a -> b
$ FinderCacheState -> InstalledModule -> Maybe InstalledFindResult
forall a. InstalledModuleEnv a -> InstalledModule -> Maybe a
lookupInstalledModuleEnv FinderCacheState
moduleLocs InstalledModule
installedMod
                                       file :: FilePath
file = case InstalledFindResult
ifr of
                                         InstalledFound ModLocation
loc InstalledModule
_ ->
                                           Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ModLocation -> Maybe FilePath
ml_hs_file ModLocation
loc
                                         InstalledFindResult
_ -> FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"hscCompileCoreExprHook: module not found"
                                 ]
           ; let hsc_env' :: HscEnv
hsc_env' = [HomeModInfo] -> HscEnv -> HscEnv
loadModulesHome ((LinkableResult -> HomeModInfo)
-> [LinkableResult] -> [HomeModInfo]
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 -}
           ; ([(Name, ForeignHValue)]
fv_hvs, [Linkable]
lbss, PkgsLoaded
pkgs) <- Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
loadDecls (HscEnv -> Interp
hscInterp HscEnv
hsc_env') HscEnv
hsc_env' SrcSpan
srcspan CompiledByteCode
bcos
           ; let hval :: (ForeignHValue, [Linkable], PkgsLoaded)
hval = ((FilePath -> Maybe ForeignHValue -> ForeignHValue
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"hscCompileCoreExpr'" (Maybe ForeignHValue -> ForeignHValue)
-> Maybe ForeignHValue -> ForeignHValue
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, ForeignHValue)] -> Maybe ForeignHValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Id -> Name
idName Id
binding_id) [(Name, ForeignHValue)]
fv_hvs), [Linkable]
lbss, PkgsLoaded
pkgs)
#else
             {- load it -}
           ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos
           ; let hval = expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs
#endif

           ; IORef (ModuleEnv ByteString)
-> (ModuleEnv ByteString -> ModuleEnv ByteString) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ModuleEnv ByteString)
var ((ModuleEnv ByteString
 -> [(Module, ByteString)] -> ModuleEnv ByteString)
-> [(Module, ByteString)]
-> ModuleEnv ByteString
-> ModuleEnv ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleEnv ByteString
-> [(Module, ByteString)] -> ModuleEnv ByteString
forall a. ModuleEnv a -> [(Module, a)] -> ModuleEnv a
extendModuleEnvList [(ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface_ 'ModIfaceFinal -> Module)
-> ModIface_ 'ModIfaceFinal -> Module
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hm, LinkableResult -> ByteString
linkableHash LinkableResult
lb) | LinkableResult
lb <- [LinkableResult]
lbs, let hm :: HomeModInfo
hm = LinkableResult -> HomeModInfo
linkableHomeMod LinkableResult
lb])
           ; (ForeignHValue, [Linkable], PkgsLoaded)
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignHValue, [Linkable], PkgsLoaded)
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 -> Maybe InstalledModule
nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB ModuleName
_ IsBootInterface
IsBoot) UnitId
_)) = Maybe InstalledModule
forall a. Maybe a
Nothing
    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB ModuleName
moduleName IsBootInterface
_) UnitId
uid)) = InstalledModule -> Maybe InstalledModule
forall a. a -> Maybe a
Just (InstalledModule -> Maybe InstalledModule)
-> InstalledModule -> Maybe InstalledModule
forall a b. (a -> b) -> a -> b
$ UnitId -> ModuleName -> InstalledModule
forall u. u -> ModuleName -> GenModule u
mkModule UnitId
uid ModuleName
moduleName
    nodeKeyToInstalledModule NodeKey
_ = Maybe InstalledModule
forall a. Maybe a
Nothing
    moduleToNodeKey :: Module -> NodeKey
    moduleToNodeKey :: Module -> NodeKey
moduleToNodeKey Module
mod = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid -> NodeKey) -> ModNodeKeyWithUid -> NodeKey
forall a b. (a -> b) -> a -> b
$ GenWithIsBoot ModuleName -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> GenWithIsBoot ModuleName
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) IsBootInterface
NotBoot) (Module -> UnitId
moduleUnitId Module
mod)
#endif

    -- Compute the transitive set of linkables required
    getTransitiveMods :: HscEnv -> UniqSet Module -> Set NodeKey
getTransitiveMods HscEnv
hsc_env UniqSet Module
needed_mods
#if MIN_VERSION_ghc(9,3,0)
      = [Set NodeKey] -> Set NodeKey
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([NodeKey] -> Set NodeKey
forall a. Ord a => [a] -> Set a
Set.fromList ((Module -> NodeKey) -> [Module] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map Module -> NodeKey
moduleToNodeKey [Module]
mods) Set NodeKey -> [Set NodeKey] -> [Set NodeKey]
forall a. a -> [a] -> [a]
: [ Set NodeKey
dep | Module
m <- [Module]
mods
                                                              , Just Set NodeKey
dep <- [NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Module -> NodeKey
moduleToNodeKey Module
m) (ModuleGraph -> Map NodeKey (Set NodeKey)
mgTransDeps (HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env))]
                                                              ])
      where mods :: [Module]
mods = UniqSet Module -> [Module]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Module
needed_mods -- OK because we put them into a set immediately after
#else
      = go emptyUniqSet needed_mods
      where
        hpt = hsc_HPT hsc_env
        go seen new
          | isEmptyUniqSet new = seen
          | otherwise = go seen' new'
            where
              seen' = seen `unionUniqSets` new
              new'  = new_deps `minusUniqSet` seen'
              new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info
                                           | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet 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 = Just (splice_hook (runMetaHook h) var) }

    splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM
    splice_hook :: Maybe (MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult)
-> IORef Splices
-> MetaRequest
-> XRec GhcTc (HsExpr GhcTc)
-> TcRn MetaResult
splice_hook ((MetaRequest
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult)
-> Maybe
     (MetaRequest
      -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult)
-> MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> TcRn MetaResult
forall a. a -> Maybe a -> a
fromMaybe MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult
MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult
defaultRunMeta -> MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult
hook) IORef Splices
var MetaRequest
metaReq XRec GhcTc (HsExpr GhcTc)
e = case MetaRequest
metaReq of
        (MetaE LHsExpr GhcPs -> MetaResult
f) -> do
            GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr' <- (MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult)
-> XRec GhcTc (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcPs)
forall (f :: * -> *).
Functor f =>
MetaHook f -> XRec GhcTc (HsExpr GhcTc) -> f (LHsExpr GhcPs)
metaRequestE MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult
MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult
hook XRec GhcTc (HsExpr GhcTc)
e
            IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IORef Splices -> (Splices -> Splices) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var ((Splices -> Splices) -> IO ()) -> (Splices -> Splices) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([(XRec GhcTc (HsExpr GhcTc), LHsExpr GhcPs)]
 -> Identity [(XRec GhcTc (HsExpr GhcTc), LHsExpr GhcPs)])
-> Splices -> Identity Splices
([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
   GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> Identity
      [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
        GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> Splices -> Identity Splices
Lens' Splices [(XRec GhcTc (HsExpr GhcTc), LHsExpr GhcPs)]
exprSplicesL (([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
    GenLocated SrcSpanAnnA (HsExpr GhcPs))]
  -> Identity
       [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         GenLocated SrcSpanAnnA (HsExpr GhcPs))])
 -> Splices -> Identity Splices)
-> ([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
      GenLocated SrcSpanAnnA (HsExpr GhcPs))]
    -> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> Splices
-> Splices
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e, GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr') :)
            MetaResult -> TcRn MetaResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetaResult -> TcRn MetaResult) -> MetaResult -> TcRn MetaResult
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> MetaResult
f LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr'
        (MetaP LPat GhcPs -> MetaResult
f) -> do
            GenLocated SrcSpanAnnA (Pat GhcPs)
pat' <- (MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult)
-> XRec GhcTc (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (LPat GhcPs)
forall (f :: * -> *).
Functor f =>
MetaHook f -> XRec GhcTc (HsExpr GhcTc) -> f (LPat GhcPs)
metaRequestP MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult
MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult
hook XRec GhcTc (HsExpr GhcTc)
e
            IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IORef Splices -> (Splices -> Splices) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var ((Splices -> Splices) -> IO ()) -> (Splices -> Splices) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([(XRec GhcTc (HsExpr GhcTc), LPat GhcPs)]
 -> Identity [(XRec GhcTc (HsExpr GhcTc), LPat GhcPs)])
-> Splices -> Identity Splices
([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
   GenLocated SrcSpanAnnA (Pat GhcPs))]
 -> Identity
      [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
        GenLocated SrcSpanAnnA (Pat GhcPs))])
-> Splices -> Identity Splices
Lens' Splices [(XRec GhcTc (HsExpr GhcTc), LPat GhcPs)]
patSplicesL (([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
    GenLocated SrcSpanAnnA (Pat GhcPs))]
  -> Identity
       [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         GenLocated SrcSpanAnnA (Pat GhcPs))])
 -> Splices -> Identity Splices)
-> ([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
      GenLocated SrcSpanAnnA (Pat GhcPs))]
    -> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         GenLocated SrcSpanAnnA (Pat GhcPs))])
-> Splices
-> Splices
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e, GenLocated SrcSpanAnnA (Pat GhcPs)
pat') :)
            MetaResult -> TcRn MetaResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetaResult -> TcRn MetaResult) -> MetaResult -> TcRn MetaResult
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> MetaResult
f LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
pat'
        (MetaT LHsType GhcPs -> MetaResult
f) -> do
            GenLocated SrcSpanAnnA (HsType GhcPs)
type' <- (MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult)
-> XRec GhcTc (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsType GhcPs)
forall (f :: * -> *).
Functor f =>
MetaHook f -> XRec GhcTc (HsExpr GhcTc) -> f (LHsType GhcPs)
metaRequestT MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult
MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult
hook XRec GhcTc (HsExpr GhcTc)
e
            IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IORef Splices -> (Splices -> Splices) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var ((Splices -> Splices) -> IO ()) -> (Splices -> Splices) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([(XRec GhcTc (HsExpr GhcTc), LHsType GhcPs)]
 -> Identity [(XRec GhcTc (HsExpr GhcTc), LHsType GhcPs)])
-> Splices -> Identity Splices
([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
   GenLocated SrcSpanAnnA (HsType GhcPs))]
 -> Identity
      [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
        GenLocated SrcSpanAnnA (HsType GhcPs))])
-> Splices -> Identity Splices
Lens' Splices [(XRec GhcTc (HsExpr GhcTc), LHsType GhcPs)]
typeSplicesL (([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
    GenLocated SrcSpanAnnA (HsType GhcPs))]
  -> Identity
       [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         GenLocated SrcSpanAnnA (HsType GhcPs))])
 -> Splices -> Identity Splices)
-> ([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
      GenLocated SrcSpanAnnA (HsType GhcPs))]
    -> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         GenLocated SrcSpanAnnA (HsType GhcPs))])
-> Splices
-> Splices
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e, GenLocated SrcSpanAnnA (HsType GhcPs)
type') :)
            MetaResult -> TcRn MetaResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetaResult -> TcRn MetaResult) -> MetaResult -> TcRn MetaResult
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> MetaResult
f LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
type'
        (MetaD [LHsDecl GhcPs] -> MetaResult
f) -> do
            [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decl' <- (MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult)
-> XRec GhcTc (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsDecl GhcPs]
forall (f :: * -> *).
Functor f =>
MetaHook f -> XRec GhcTc (HsExpr GhcTc) -> f [LHsDecl GhcPs]
metaRequestD MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult
MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult
hook XRec GhcTc (HsExpr GhcTc)
e
            IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IORef Splices -> (Splices -> Splices) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var ((Splices -> Splices) -> IO ()) -> (Splices -> Splices) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([(XRec GhcTc (HsExpr GhcTc), [LHsDecl GhcPs])]
 -> Identity [(XRec GhcTc (HsExpr GhcTc), [LHsDecl GhcPs])])
-> Splices -> Identity Splices
([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
   [GenLocated SrcSpanAnnA (HsDecl GhcPs)])]
 -> Identity
      [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)])])
-> Splices -> Identity Splices
Lens' Splices [(XRec GhcTc (HsExpr GhcTc), [LHsDecl GhcPs])]
declSplicesL (([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)])]
  -> Identity
       [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         [GenLocated SrcSpanAnnA (HsDecl GhcPs)])])
 -> Splices -> Identity Splices)
-> ([(GenLocated SrcSpanAnnA (HsExpr GhcTc),
      [GenLocated SrcSpanAnnA (HsDecl GhcPs)])]
    -> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
         [GenLocated SrcSpanAnnA (HsDecl GhcPs)])])
-> Splices
-> Splices
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decl') :)
            MetaResult -> TcRn MetaResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetaResult -> TcRn MetaResult) -> MetaResult -> TcRn MetaResult
forall a b. (a -> b) -> a -> b
$ [LHsDecl GhcPs] -> MetaResult
f [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decl'
        (MetaAW Serialized -> MetaResult
f) -> do
            Serialized
aw' <- (MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult)
-> XRec GhcTc (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) Serialized
forall (f :: * -> *).
Functor f =>
MetaHook f -> XRec GhcTc (HsExpr GhcTc) -> f Serialized
metaRequestAW MetaRequest -> XRec GhcTc (HsExpr GhcTc) -> TcRn MetaResult
MetaRequest
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> TcRn MetaResult
hook XRec GhcTc (HsExpr GhcTc)
e
            IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IORef Splices -> (Splices -> Splices) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Splices
var ((Splices -> Splices) -> IO ()) -> (Splices -> Splices) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([(XRec GhcTc (HsExpr GhcTc), Serialized)]
 -> Identity [(XRec GhcTc (HsExpr GhcTc), Serialized)])
-> Splices -> Identity Splices
([(GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)]
 -> Identity [(GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)])
-> Splices -> Identity Splices
Lens' Splices [(XRec GhcTc (HsExpr GhcTc), Serialized)]
awSplicesL (([(GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)]
  -> Identity [(GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)])
 -> Splices -> Identity Splices)
-> ([(GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)]
    -> [(GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)])
-> Splices
-> Splices
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e, Serialized
aw') :)
            MetaResult -> TcRn MetaResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetaResult -> TcRn MetaResult) -> MetaResult -> TcRn MetaResult
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 (LHsDoc GhcRn))
mrn_info), Splices
splices, ModuleEnv ByteString
mod_env)
      <- TypecheckHelpers
-> HscEnv
-> (HscEnv
    -> IO
         (TcGblEnv,
          Maybe
            (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
             Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
             Maybe (LHsDoc GhcRn))))
-> IO
     ((TcGblEnv,
       Maybe
         (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
          Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
          Maybe (LHsDoc GhcRn))),
      Splices, ModuleEnv ByteString)
forall a.
TypecheckHelpers
-> HscEnv
-> (HscEnv -> IO a)
-> IO (a, Splices, ModuleEnv ByteString)
captureSplicesAndDeps TypecheckHelpers
tc_helpers HscEnv
hsc_env_tmp ((HscEnv
  -> IO
       (TcGblEnv,
        Maybe
          (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
           Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
           Maybe (LHsDoc GhcRn))))
 -> IO
      ((TcGblEnv,
        Maybe
          (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
           Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
           Maybe (LHsDoc GhcRn))),
       Splices, ModuleEnv ByteString))
-> (HscEnv
    -> IO
         (TcGblEnv,
          Maybe
            (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
             Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
             Maybe (LHsDoc GhcRn))))
-> IO
     ((TcGblEnv,
       Maybe
         (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
          Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
          Maybe (LHsDoc GhcRn))),
      Splices, ModuleEnv ByteString)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hscEnvTmp ->
             do  HscEnv
-> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename HscEnv
hscEnvTmp ModSummary
ms (HsParsedModule -> IO (TcGblEnv, RenamedStuff))
-> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
forall a b. (a -> b) -> a -> b
$
                          HsParsedModule { hpm_module :: ParsedSource
hpm_module = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
                                           hpm_src_files :: [FilePath]
hpm_src_files = ParsedModule -> [FilePath]
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 (LHsDoc GhcRn))
rn_info = case Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
mrn_info of
        Just (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
 Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
 Maybe (LHsDoc GhcRn))
x  -> (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
 Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
 Maybe (LHsDoc GhcRn))
x
        Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
Nothing -> FilePath
-> (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
    Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
    Maybe (LHsDoc GhcRn))
forall a. HasCallStack => FilePath -> a
error FilePath
"no renamed info tcRnModule"

      -- Serialize mod_env so we can read it from the interface
      mod_env_anns :: [Annotation]
mod_env_anns = ((Module, ByteString) -> Annotation)
-> [(Module, ByteString)] -> [Annotation]
forall a b. (a -> b) -> [a] -> [b]
map (\(Module
mod, ByteString
hash) -> CoreAnnTarget -> Serialized -> Annotation
Annotation (Module -> CoreAnnTarget
forall name. Module -> AnnTarget name
ModuleTarget Module
mod) (Serialized -> Annotation) -> Serialized -> Annotation
forall a b. (a -> b) -> a -> b
$ (ByteString -> [Word8]) -> ByteString -> Serialized
forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized ByteString -> [Word8]
BS.unpack ByteString
hash)
                         (ModuleEnv ByteString -> [(Module, ByteString)]
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 = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
  TcModuleResult -> IO TcModuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedModule
-> RenamedSource
-> TcGblEnv
-> Splices
-> Bool
-> ModuleEnv ByteString
-> TcModuleResult
TcModuleResult ParsedModule
pmod RenamedSource
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
 Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
 Maybe (LHsDoc GhcRn))
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 :: [Usage] -> [Usage]
filterUsages = (Usage -> Bool) -> [Usage] -> [Usage]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Usage -> Bool) -> [Usage] -> [Usage])
-> (Usage -> Bool) -> [Usage] -> [Usage]
forall a b. (a -> b) -> a -> b
$ \case UsageHomeModuleInterface{} -> Bool
False
                              Usage
_ -> Bool
True
#else
filterUsages = 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_ 'ModIfaceFinal -> ModIface_ 'ModIfaceFinal
shareUsages ModIface_ 'ModIfaceFinal
iface
  = ModIface_ 'ModIfaceFinal
iface
-- Fixed upstream in GHC 9.8
#if !MIN_VERSION_ghc(9,7,0)
      {mi_usages = usages}
  where usages :: [Usage]
usages = (Usage -> Usage) -> [Usage] -> [Usage]
forall a b. (a -> b) -> [a] -> [b]
map Usage -> Usage
go (ModIface_ 'ModIfaceFinal -> [Usage]
forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages ModIface_ 'ModIfaceFinal
iface)
        go :: Usage -> Usage
go usg :: Usage
usg@UsageFile{} = Usage
usg {usg_file_path = fp}
          where !fp :: FilePath
fp = FilePath -> FilePath
shareFilePath (Usage -> FilePath
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 (ParsedModule -> ModSummary) -> ParsedModule -> ModSummary
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_ 'ModIfaceFinal
iface' <- HscEnv
-> SafeHaskellMode
-> ModDetails
-> ModSummary
-> Maybe CoreProgram
-> TcGblEnv
-> IO (ModIface_ 'ModIfaceFinal)
mkIfaceTc HscEnv
hsc_env_tmp SafeHaskellMode
sf ModDetails
details ModSummary
ms Maybe CoreProgram
forall a. Maybe a
Nothing TcGblEnv
tcGblEnv
  let iface :: ModIface_ 'ModIfaceFinal
iface = ModIface_ 'ModIfaceFinal
iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface]
  HiFileResult -> IO HiFileResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HiFileResult -> IO HiFileResult)
-> HiFileResult -> IO HiFileResult
forall a b. (a -> b) -> a -> b
$! ModSummary
-> ModIface_ 'ModIfaceFinal
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface_ 'ModIfaceFinal
iface ModDetails
details (TcModuleResult -> ModuleEnv ByteString
tmrRuntimeModules TcModuleResult
tcm) Maybe (CoreFile, ByteString)
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 (IO (IdeResult HiFileResult) -> IO (IdeResult HiFileResult))
-> IO (IdeResult HiFileResult) -> IO (IdeResult HiFileResult)
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 (ParsedModule -> ModSummary) -> ParsedModule -> ModSummary
forall a b. (a -> b) -> a -> b
$ TcModuleResult -> ParsedModule
tmrParsed TcModuleResult
tcm

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

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

  ModIface_ 'ModIfaceFinal
final_iface' <- HscEnv
-> PartialModIface
-> Maybe StgCgInfos
-> Maybe CmmCgInfos
-> IO (ModIface_ 'ModIfaceFinal)
mkFullIface HscEnv
session PartialModIface
partial_iface Maybe StgCgInfos
forall a. Maybe a
Nothing
#if MIN_VERSION_ghc(9,4,2)
                    Maybe CmmCgInfos
forall a. Maybe a
Nothing
#endif
  let final_iface :: ModIface_ 'ModIfaceFinal
final_iface = ModIface_ 'ModIfaceFinal
final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages 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 :: FilePath
core_fp  = ModLocation -> FilePath
ml_core_file (ModLocation -> FilePath) -> ModLocation -> FilePath
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_ 'ModIfaceFinal -> Fingerprint
getModuleHash ModIface_ 'ModIfaceFinal
final_iface
        Fingerprint
core_hash1 <- ShakeExtras
-> FilePath -> (FilePath -> IO Fingerprint) -> IO Fingerprint
forall a. ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
atomicFileWrite ShakeExtras
se FilePath
core_fp ((FilePath -> IO Fingerprint) -> IO Fingerprint)
-> (FilePath -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \FilePath
fp ->
          FilePath -> CoreFile -> IO Fingerprint
writeBinCoreFile FilePath
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 -> FilePath -> IO (CoreFile, Fingerprint)
readBinCoreFile (NameCacheUpdater -> NameCacheUpdater
mkUpdater (NameCacheUpdater -> NameCacheUpdater)
-> NameCacheUpdater -> NameCacheUpdater
forall a b. (a -> b) -> a -> b
$ HscEnv -> NameCacheUpdater
hsc_NC HscEnv
session) FilePath
core_fp
        Maybe (CoreFile, ByteString) -> IO (Maybe (CoreFile, ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CoreFile, ByteString) -> IO (Maybe (CoreFile, ByteString)))
-> Maybe (CoreFile, ByteString)
-> IO (Maybe (CoreFile, ByteString))
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe (CoreFile, ByteString) -> Maybe (CoreFile, ByteString)
forall a. HasCallStack => Bool -> a -> a
assert (Fingerprint
core_hash1 Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
core_hash2)
             (Maybe (CoreFile, ByteString) -> Maybe (CoreFile, ByteString))
-> Maybe (CoreFile, ByteString) -> Maybe (CoreFile, ByteString)
forall a b. (a -> b) -> a -> b
$ (CoreFile, ByteString) -> Maybe (CoreFile, ByteString)
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 :: IdeOptions -> Bool
optVerifyCoreFile :: 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 :: FilePath
core_fp = ModLocation -> FilePath
ml_core_file (ModLocation -> FilePath) -> ModLocation -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
ms
      FilePath -> IO ()
traceIO (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Verifying " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
      CgGuts{cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
unprep_binds'} <- HscEnv
-> ModIface_ 'ModIfaceFinal -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts HscEnv
session ModIface_ 'ModIfaceFinal
final_iface ModDetails
details CoreFile
core

#if MIN_VERSION_ghc(9,5,0)
      CorePrepConfig
cp_cfg <- HscEnv -> IO CorePrepConfig
initCorePrepConfig HscEnv
session
#endif

      let corePrep :: CoreProgram -> [TyCon] -> IO CoreProgram
corePrep = Logger
-> CorePrepConfig
-> CorePrepPgmConfig
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm
#if MIN_VERSION_ghc(9,5,0)
                       (HscEnv -> Logger
hsc_logger HscEnv
session) CorePrepConfig
cp_cfg (DynFlags -> [Id] -> CorePrepPgmConfig
initCorePrepPgmConfig (HscEnv -> DynFlags
hsc_dflags HscEnv
session) (InteractiveContext -> [Id]
interactiveInScope (InteractiveContext -> [Id]) -> InteractiveContext -> [Id]
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
session))
#else
                       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)
      CoreProgram
prepd_binds
#else
      (prepd_binds , _)
#endif
        <- CoreProgram -> [TyCon] -> IO CoreProgram
corePrep CoreProgram
unprep_binds [TyCon]
data_tycons
#if MIN_VERSION_ghc(9,3,0)
      CoreProgram
prepd_binds'
#else
      (prepd_binds', _)
#endif
        <- CoreProgram -> [TyCon] -> IO CoreProgram
corePrep CoreProgram
unprep_binds' [TyCon]
data_tycons
      let binds :: [[(Id, CoreExpr)]]
binds  = [[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]]
noUnfoldings ([[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]])
-> [[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]]
forall a b. (a -> b) -> a -> b
$ ((CoreProgram -> [(Id, CoreExpr)])
-> [CoreProgram] -> [[(Id, CoreExpr)]]
forall a b. (a -> b) -> [a] -> [b]
map CoreProgram -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds ([CoreProgram] -> [[(Id, CoreExpr)]])
-> (CoreProgram -> [CoreProgram])
-> CoreProgram
-> [[(Id, CoreExpr)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreProgram -> [CoreProgram] -> [CoreProgram]
forall a. a -> [a] -> [a]
:[])) CoreProgram
prepd_binds
          binds' :: [[(Id, CoreExpr)]]
binds' = [[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]]
noUnfoldings ([[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]])
-> [[(Id, CoreExpr)]] -> [[(Id, CoreExpr)]]
forall a b. (a -> b) -> a -> b
$ ((CoreProgram -> [(Id, CoreExpr)])
-> [CoreProgram] -> [[(Id, CoreExpr)]]
forall a b. (a -> b) -> [a] -> [b]
map CoreProgram -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds ([CoreProgram] -> [[(Id, CoreExpr)]])
-> (CoreProgram -> [CoreProgram])
-> CoreProgram
-> [[(Id, CoreExpr)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreProgram -> [CoreProgram] -> [CoreProgram]
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 = [[SDoc]] -> [SDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SDoc]] -> [SDoc]) -> [[SDoc]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (State RnEnv2 [[SDoc]] -> RnEnv2 -> [[SDoc]])
-> RnEnv2 -> State RnEnv2 [[SDoc]] -> [[SDoc]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State RnEnv2 [[SDoc]] -> RnEnv2 -> [[SDoc]]
forall s a. State s a -> s -> a
S.evalState (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet) (State RnEnv2 [[SDoc]] -> [[SDoc]])
-> State RnEnv2 [[SDoc]] -> [[SDoc]]
forall a b. (a -> b) -> a -> b
$ ([(Id, CoreExpr)]
 -> [(Id, CoreExpr)] -> StateT RnEnv2 Identity [SDoc])
-> [[(Id, CoreExpr)]]
-> [[(Id, CoreExpr)]]
-> State RnEnv2 [[SDoc]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM [(Id, CoreExpr)]
-> [(Id, CoreExpr)] -> StateT RnEnv2 Identity [SDoc]
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 = (RnEnv2 -> ([SDoc], RnEnv2)) -> StateT RnEnv2 m [SDoc]
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
S.state ((RnEnv2 -> ([SDoc], RnEnv2)) -> StateT RnEnv2 m [SDoc])
-> (RnEnv2 -> ([SDoc], RnEnv2)) -> StateT RnEnv2 m [SDoc]
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. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ (Id -> Id) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((Id -> Id) -> a -> a) -> (Id -> Id) -> a -> a
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


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

  IdeResult HiFileResult -> IO (IdeResult HiFileResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], HiFileResult -> Maybe HiFileResult
forall a. a -> Maybe a
Just (HiFileResult -> Maybe HiFileResult)
-> HiFileResult -> Maybe HiFileResult
forall a b. (a -> b) -> a -> b
$! ModSummary
-> ModIface_ 'ModIfaceFinal
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface_ 'ModIfaceFinal
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 IO (IdeResult HiFileResult)
-> [Handler IO (IdeResult HiFileResult)]
-> IO (IdeResult HiFileResult)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches`
      [ (GhcException -> IO (IdeResult HiFileResult))
-> Handler IO (IdeResult HiFileResult)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((GhcException -> IO (IdeResult HiFileResult))
 -> Handler IO (IdeResult HiFileResult))
-> (GhcException -> IO (IdeResult HiFileResult))
-> Handler IO (IdeResult HiFileResult)
forall a b. (a -> b) -> a -> b
$ IdeResult HiFileResult -> IO (IdeResult HiFileResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdeResult HiFileResult -> IO (IdeResult HiFileResult))
-> (GhcException -> IdeResult HiFileResult)
-> GhcException
-> IO (IdeResult HiFileResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Maybe HiFileResult
forall a. Maybe a
Nothing) ([FileDiagnostic] -> IdeResult HiFileResult)
-> (GhcException -> [FileDiagnostic])
-> GhcException
-> IdeResult HiFileResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
source DynFlags
dflags
      , (SomeException -> IO (IdeResult HiFileResult))
-> Handler IO (IdeResult HiFileResult)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeException -> IO (IdeResult HiFileResult))
 -> Handler IO (IdeResult HiFileResult))
-> (SomeException -> IO (IdeResult HiFileResult))
-> Handler IO (IdeResult HiFileResult)
forall a b. (a -> b) -> a -> b
$ IdeResult HiFileResult -> IO (IdeResult HiFileResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdeResult HiFileResult -> IO (IdeResult HiFileResult))
-> (SomeException -> IdeResult HiFileResult)
-> SomeException
-> IO (IdeResult HiFileResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Maybe HiFileResult
forall a. Maybe a
Nothing) ([FileDiagnostic] -> IdeResult HiFileResult)
-> (SomeException -> [FileDiagnostic])
-> SomeException
-> IdeResult HiFileResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> DiagnosticSeverity -> SrcSpan -> FilePath -> [FileDiagnostic]
diagFromString Text
source DiagnosticSeverity
DiagnosticSeverity_Error (FilePath -> SrcSpan
noSpan FilePath
"<internal>")
      (FilePath -> [FileDiagnostic])
-> (SomeException -> FilePath) -> SomeException -> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
"Error during " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
source) ++) (FilePath -> FilePath)
-> (SomeException -> FilePath) -> SomeException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
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 =
    (Either [FileDiagnostic] ([FileDiagnostic], ModGuts)
 -> IdeResult ModGuts)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], ModGuts))
-> IO (IdeResult ModGuts)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FileDiagnostic] -> IdeResult ModGuts)
-> (([FileDiagnostic], ModGuts) -> IdeResult ModGuts)
-> Either [FileDiagnostic] ([FileDiagnostic], ModGuts)
-> IdeResult ModGuts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, Maybe ModGuts
forall a. Maybe a
Nothing) ((ModGuts -> Maybe ModGuts)
-> ([FileDiagnostic], ModGuts) -> IdeResult ModGuts
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ModGuts -> Maybe ModGuts
forall a. a -> Maybe a
Just)) (IO (Either [FileDiagnostic] ([FileDiagnostic], ModGuts))
 -> IO (IdeResult ModGuts))
-> IO (Either [FileDiagnostic] ([FileDiagnostic], ModGuts))
-> IO (IdeResult ModGuts)
forall a b. (a -> b) -> a -> b
$
        DynFlags
-> Text
-> IO ([FileDiagnostic], ModGuts)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], ModGuts))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
session) Text
"compile" (IO ([FileDiagnostic], ModGuts)
 -> IO (Either [FileDiagnostic] ([FileDiagnostic], ModGuts)))
-> IO ([FileDiagnostic], ModGuts)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], ModGuts))
forall a b. (a -> b) -> a -> b
$ do
            ([(Maybe DiagnosticReason, FileDiagnostic)]
warnings,ModGuts
desugared_guts) <- Text
-> ((HscEnv -> HscEnv) -> IO ModGuts)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], ModGuts)
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
withWarnings Text
"compile" (((HscEnv -> HscEnv) -> IO ModGuts)
 -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], ModGuts))
-> ((HscEnv -> HscEnv) -> IO ModGuts)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], ModGuts)
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 (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ (DynFlags -> HscEnv -> HscEnv) -> HscEnv -> DynFlags -> HscEnv
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
                                    (DynFlags -> HscEnv) -> DynFlags -> HscEnv
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 = hsc_dflags session' }) TcGblEnv
tcg
               if Bool
simplify
               then do
                 [FilePath]
plugins <- IORef [FilePath] -> IO [FilePath]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [FilePath]
tcg_th_coreplugins TcGblEnv
tcg)
                 HscEnv -> [FilePath] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
session' [FilePath]
plugins ModGuts
desugar
               else ModGuts -> IO ModGuts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModGuts
desugar
            ([FileDiagnostic], ModGuts) -> IO ([FileDiagnostic], ModGuts)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Maybe DiagnosticReason, FileDiagnostic) -> FileDiagnostic)
-> [(Maybe DiagnosticReason, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DiagnosticReason, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(Maybe DiagnosticReason, 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
    (Either [FileDiagnostic] ([FileDiagnostic], Linkable)
 -> IdeResult Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
-> IO (IdeResult Linkable)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FileDiagnostic] -> IdeResult Linkable)
-> (([FileDiagnostic], Linkable) -> IdeResult Linkable)
-> Either [FileDiagnostic] ([FileDiagnostic], Linkable)
-> IdeResult Linkable
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, Maybe Linkable
forall a. Maybe a
Nothing) ((Linkable -> Maybe Linkable)
-> ([FileDiagnostic], Linkable) -> IdeResult Linkable
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just)) (IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
 -> IO (IdeResult Linkable))
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
-> IO (IdeResult Linkable)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> Text
-> IO ([FileDiagnostic], Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
session) Text
"object" (IO ([FileDiagnostic], Linkable)
 -> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable)))
-> IO ([FileDiagnostic], Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
forall a b. (a -> b) -> a -> b
$ do
              let dot_o :: FilePath
dot_o =  ModLocation -> FilePath
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
                  mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
summary
                  fp :: FilePath
fp = FilePath -> FilePath -> FilePath
replaceExtension FilePath
dot_o FilePath
"s"
              Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
fp)
              ([(Maybe DiagnosticReason, FileDiagnostic)]
warnings, FilePath
dot_o_fp) <-
                Text
-> ((HscEnv -> HscEnv) -> IO FilePath)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], FilePath)
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
withWarnings Text
"object" (((HscEnv -> HscEnv) -> IO FilePath)
 -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], FilePath))
-> ((HscEnv -> HscEnv) -> IO FilePath)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], FilePath)
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 (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Int -> DynFlags -> DynFlags
updOptLevel Int
0 (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> DynFlags -> DynFlags
setOutputFile
#if MIN_VERSION_ghc(9,3,0)
                              (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dot_o)
#else
                              dot_o
#endif
                            (DynFlags -> DynFlags) -> DynFlags -> DynFlags
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)
                      (FilePath
outputFilename, Maybe FilePath
_mStub, [(ForeignSrcLang, FilePath)]
_foreign_files, Maybe StgCgInfos
_cinfos, Maybe CmmCgInfos
_stgcinfos) <- HscEnv
-> CgGuts
-> ModLocation
-> FilePath
-> IO
     (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)],
      Maybe StgCgInfos, Maybe CmmCgInfos)
hscGenHardCode HscEnv
session' CgGuts
guts
#else
                      (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts
#endif
                                (ModSummary -> ModLocation
ms_location ModSummary
summary)
                                FilePath
fp
                      Maybe FilePath
obj <- HscEnv
-> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
compileFile HscEnv
session' StopPhase
driverNoStop (FilePath
outputFilename, Phase -> Maybe Phase
forall a. a -> Maybe a
Just (Bool -> Phase
As Bool
False))
#if MIN_VERSION_ghc(9,3,0)
                      case Maybe FilePath
obj of
                        Maybe FilePath
Nothing -> GhcException -> IO FilePath
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO FilePath) -> GhcException -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
Panic FilePath
"compileFile didn't generate object code"
                        Just FilePath
x -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
#else
                      return obj
#endif
              let unlinked :: Unlinked
unlinked = FilePath -> Unlinked
DotO FilePath
dot_o_fp
              -- Need time to be the modification time for recompilation checking
              UTCTime
t <- IO UTCTime -> IO UTCTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO UTCTime) -> IO UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationTime FilePath
dot_o_fp
              let linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
t Module
mod [Unlinked
unlinked]

              ([FileDiagnostic], Linkable) -> IO ([FileDiagnostic], Linkable)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Maybe DiagnosticReason, FileDiagnostic) -> FileDiagnostic)
-> [(Maybe DiagnosticReason, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DiagnosticReason, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(Maybe DiagnosticReason, 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
    (Either [FileDiagnostic] ([FileDiagnostic], Linkable)
 -> IdeResult Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
-> IO (IdeResult Linkable)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FileDiagnostic] -> IdeResult Linkable)
-> (([FileDiagnostic], Linkable) -> IdeResult Linkable)
-> Either [FileDiagnostic] ([FileDiagnostic], Linkable)
-> IdeResult Linkable
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, Maybe Linkable
forall a. Maybe a
Nothing) ((Linkable -> Maybe Linkable)
-> ([FileDiagnostic], Linkable) -> IdeResult Linkable
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just)) (IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
 -> IO (IdeResult Linkable))
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
-> IO (IdeResult Linkable)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> Text
-> IO ([FileDiagnostic], Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv) Text
"bytecode" (IO ([FileDiagnostic], Linkable)
 -> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable)))
-> IO ([FileDiagnostic], Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
forall a b. (a -> b) -> a -> b
$ do
              ([(Maybe DiagnosticReason, FileDiagnostic)]
warnings, (Maybe FilePath
_, CompiledByteCode
bytecode, [SptEntry]
sptEntries)) <-
                Text
-> ((HscEnv -> HscEnv)
    -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
-> IO
     ([(Maybe DiagnosticReason, FileDiagnostic)],
      (Maybe FilePath, CompiledByteCode, [SptEntry]))
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
withWarnings Text
"bytecode" (((HscEnv -> HscEnv)
  -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
 -> IO
      ([(Maybe DiagnosticReason, FileDiagnostic)],
       (Maybe FilePath, CompiledByteCode, [SptEntry])))
-> ((HscEnv -> HscEnv)
    -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
-> IO
     ([(Maybe DiagnosticReason, FileDiagnostic)],
      (Maybe FilePath, CompiledByteCode, [SptEntry]))
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 = hsc_dflags session }
                      HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
session (CgGuts -> CgInteractiveGuts
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]
              ([FileDiagnostic], Linkable) -> IO ([FileDiagnostic], Linkable)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Maybe DiagnosticReason, FileDiagnostic) -> FileDiagnostic)
-> [(Maybe DiagnosticReason, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DiagnosticReason, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(Maybe DiagnosticReason, FileDiagnostic)]
warnings, Linkable
linkable)

demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings =
  ((ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
update_pm_mod_summary ((ModSummary -> ModSummary) -> ParsedModule -> ParsedModule)
-> ((DynFlags -> DynFlags) -> ModSummary -> ModSummary)
-> (DynFlags -> DynFlags)
-> ParsedModule
-> ParsedModule
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)
                   (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> WarningFlag -> DynFlags
`wopt_set` WarningFlag
Opt_WarnTypedHoles)
                   (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> WarningFlag -> DynFlags
`wopt_set` WarningFlag
Opt_WarnDeferredOutOfScopeVariables)
                   (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_DeferTypeErrors)
                   (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_DeferTypedHoles)
                   (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
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 = up $ ms_hspp_opts 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 = up $ pm_mod_summary pm}

#if MIN_VERSION_ghc(9,3,0)
unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer (Just (WarningWithFlag WarningFlag
Opt_WarnDeferredTypeErrors)         , FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
unDefer (Just (WarningWithFlag WarningFlag
Opt_WarnTypedHoles)                 , FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
unDefer (Just (WarningWithFlag WarningFlag
Opt_WarnDeferredOutOfScopeVariables), FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
#else
unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd)
unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd)
unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)
#endif
unDefer ( Maybe DiagnosticReason
_                                        , 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{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where
  warn2err :: T.Text -> T.Text
  warn2err :: Text -> Text
warn2err = Text -> [Text] -> Text
T.intercalate Text
": error:" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
": warning:"

#if MIN_VERSION_ghc(9,3,0)
hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
hideDiag :: DynFlags
-> (Maybe DiagnosticReason, FileDiagnostic)
-> (Maybe DiagnosticReason, FileDiagnostic)
hideDiag DynFlags
originalFlags (w :: Maybe DiagnosticReason
w@(Just (WarningWithFlag WarningFlag
warning)), (NormalizedFilePath
nfp, ShowDiagnostic
_sh, Diagnostic
fd))
#else
hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd))
#endif
  | Bool -> Bool
not (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
warning DynFlags
originalFlags)
  = (Maybe DiagnosticReason
w, (NormalizedFilePath
nfp, ShowDiagnostic
HideDiag, Diagnostic
fd))
hideDiag DynFlags
_originalFlags (Maybe DiagnosticReason, FileDiagnostic)
t = (Maybe DiagnosticReason, 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 :: (Maybe DiagnosticReason, FileDiagnostic)
-> (Maybe DiagnosticReason, FileDiagnostic)
tagDiag (w :: Maybe DiagnosticReason
w@(Just (WarningWithFlag WarningFlag
warning)), (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd))
  | Just DiagnosticTag
tag <- WarningFlag -> Maybe DiagnosticTag
requiresTag WarningFlag
warning
  = (Maybe DiagnosticReason
w, (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd { _tags = Just $ tag : concat (_tags fd) }))
#else
tagDiag (w@(Reason warning), (nfp, sh, fd))
  | Just tag <- requiresTag warning
  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags 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
      = DiagnosticTag -> Maybe DiagnosticTag
forall a. a -> Maybe a
Just DiagnosticTag
DiagnosticTag_Deprecated
#endif
    requiresTag WarningFlag
wflag  -- deprecation was already considered above
      | WarningFlag
wflag WarningFlag -> [WarningFlag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WarningFlag]
unnecessaryDeprecationWarningFlags
      = DiagnosticTag -> Maybe DiagnosticTag
forall a. a -> Maybe a
Just DiagnosticTag
DiagnosticTag_Unnecessary
    requiresTag WarningFlag
_ = Maybe DiagnosticTag
forall a. Maybe a
Nothing
-- other diagnostics are left unaffected
tagDiag (Maybe DiagnosticReason, FileDiagnostic)
t = (Maybe DiagnosticReason, FileDiagnostic)
t

addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
addRelativeImport NormalizedFilePath
fp ModuleName
modu DynFlags
dflags = DynFlags
dflags
    {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

-- | Also resets the interface store
atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
atomicFileWrite :: forall a. ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
atomicFileWrite ShakeExtras
se FilePath
targetPath FilePath -> IO a
write = do
  let dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
targetPath
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
  (FilePath
tempFilePath, IO ()
cleanUp) <- FilePath -> IO (FilePath, IO ())
newTempFileWithin FilePath
dir
  (FilePath -> IO a
write FilePath
tempFilePath IO a -> (a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> FilePath -> FilePath -> IO ()
renameFile FilePath
tempFilePath FilePath
targetPath IO () -> IO [Key] -> IO [Key]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM [Key] -> IO [Key]
forall a. STM a -> IO a
atomically (ShakeExtras -> NormalizedFilePath -> STM [Key]
resetInterfaceStore ShakeExtras
se (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
targetPath)) IO [Key] -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
    IO a -> IO () -> IO a
forall (m :: * -> *) a b.
(HasCallStack, 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 =
  DynFlags
-> Text
-> IO (Maybe (HieASTs Type))
-> IO ([FileDiagnostic], Maybe (HieASTs Type))
forall a.
DynFlags -> Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
handleGenerationErrors' DynFlags
dflags Text
"extended interface generation" (IO (Maybe (HieASTs Type))
 -> IO ([FileDiagnostic], Maybe (HieASTs Type)))
-> IO (Maybe (HieASTs Type))
-> IO ([FileDiagnostic], Maybe (HieASTs Type))
forall a b. (a -> b) -> a -> b
$ HscEnv -> Hsc (Maybe (HieASTs Type)) -> IO (Maybe (HieASTs Type))
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hscEnv (Hsc (Maybe (HieASTs Type)) -> IO (Maybe (HieASTs Type)))
-> Hsc (Maybe (HieASTs Type)) -> IO (Maybe (HieASTs Type))
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 = [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
Util.listToBag ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (IdP GhcTc -> XRec GhcTc (HsExpr GhcTc) -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Id
unitDataConId) (Splices -> [XRec GhcTc (HsExpr GhcTc)]
spliceExpressions (Splices -> [XRec GhcTc (HsExpr GhcTc)])
-> Splices -> [XRec GhcTc (HsExpr GhcTc)]
forall a b. (a -> b) -> a -> b
$ TcModuleResult -> Splices
tmrTopLevelSplices TcModuleResult
tcm))
        real_binds :: LHsBinds GhcTc
real_binds = TcGblEnv -> LHsBinds GhcTc
tcg_binds (TcGblEnv -> LHsBinds GhcTc) -> TcGblEnv -> LHsBinds GhcTc
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
-> Hsc (Maybe (HieASTs Type)) -> Hsc (Maybe (HieASTs Type))
forall {p} {a}. p -> a -> a
run TcGblEnv
ts (Hsc (Maybe (HieASTs Type)) -> Hsc (Maybe (HieASTs Type)))
-> Hsc (Maybe (HieASTs Type)) -> Hsc (Maybe (HieASTs Type))
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_ghc(9,3,0)
      Maybe (HieASTs Type) -> Hsc (Maybe (HieASTs Type))
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (HieASTs Type) -> Hsc (Maybe (HieASTs Type)))
-> Maybe (HieASTs Type) -> Hsc (Maybe (HieASTs Type))
forall a b. (a -> b) -> a -> b
$ HieASTs Type -> Maybe (HieASTs Type)
forall a. a -> Maybe a
Just (HieASTs Type -> Maybe (HieASTs Type))
-> HieASTs Type -> Maybe (HieASTs Type)
forall a b. (a -> b) -> a -> b
$
#else
      Just <$>
#endif
          LHsBinds GhcTc
-> RenamedSource
-> Bag EvBind
-> [ClsInst]
-> [TyCon]
-> HieASTs Type
GHC.enrichHie (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
fake_splice_binds Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`Util.unionBags` LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc 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 :: p -> a -> a
run p
_ts = -- ts is only used in GHC 9.2
#if !MIN_VERSION_ghc(9,3,0)
        fmap (join . snd) . liftIO . initDs hscEnv _ts
#else
        a -> a
forall a. a -> a
id
#endif

spliceExpressions :: Splices -> [LHsExpr GhcTc]
spliceExpressions :: Splices -> [XRec GhcTc (HsExpr GhcTc)]
spliceExpressions Splices{[(XRec GhcTc (HsExpr GhcTc), [LHsDecl GhcPs])]
[(XRec GhcTc (HsExpr GhcTc), LPat GhcPs)]
[(XRec GhcTc (HsExpr GhcTc), LHsExpr GhcPs)]
[(XRec GhcTc (HsExpr GhcTc), LHsType GhcPs)]
[(XRec GhcTc (HsExpr GhcTc), Serialized)]
exprSplices :: [(XRec GhcTc (HsExpr GhcTc), LHsExpr GhcPs)]
patSplices :: [(XRec GhcTc (HsExpr GhcTc), LPat GhcPs)]
typeSplices :: [(XRec GhcTc (HsExpr GhcTc), LHsType GhcPs)]
declSplices :: [(XRec GhcTc (HsExpr GhcTc), [LHsDecl GhcPs])]
awSplices :: [(XRec GhcTc (HsExpr GhcTc), Serialized)]
exprSplices :: Splices -> [(XRec GhcTc (HsExpr GhcTc), LHsExpr GhcPs)]
patSplices :: Splices -> [(XRec GhcTc (HsExpr GhcTc), LPat GhcPs)]
typeSplices :: Splices -> [(XRec GhcTc (HsExpr GhcTc), LHsType GhcPs)]
declSplices :: Splices -> [(XRec GhcTc (HsExpr GhcTc), [LHsDecl GhcPs])]
awSplices :: Splices -> [(XRec GhcTc (HsExpr GhcTc), Serialized)]
..} =
    DList (XRec GhcTc (HsExpr GhcTc)) -> [XRec GhcTc (HsExpr GhcTc)]
forall a. DList a -> [a]
DL.toList (DList (XRec GhcTc (HsExpr GhcTc)) -> [XRec GhcTc (HsExpr GhcTc)])
-> DList (XRec GhcTc (HsExpr GhcTc)) -> [XRec GhcTc (HsExpr GhcTc)]
forall a b. (a -> b) -> a -> b
$ [DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. Monoid a => [a] -> a
mconcat
        [ [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. [a] -> DList a
DL.fromList ([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
 -> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ ((GenLocated SrcSpanAnnA (HsExpr GhcTc),
  GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsExpr GhcTc),
 GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a, b) -> a
fst [(XRec GhcTc (HsExpr GhcTc), LHsExpr GhcPs)]
[(GenLocated SrcSpanAnnA (HsExpr GhcTc),
  GenLocated SrcSpanAnnA (HsExpr GhcPs))]
exprSplices
        , [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. [a] -> DList a
DL.fromList ([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
 -> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ ((GenLocated SrcSpanAnnA (HsExpr GhcTc),
  GenLocated SrcSpanAnnA (Pat GhcPs))
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
     GenLocated SrcSpanAnnA (Pat GhcPs))]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsExpr GhcTc),
 GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a, b) -> a
fst [(XRec GhcTc (HsExpr GhcTc), LPat GhcPs)]
[(GenLocated SrcSpanAnnA (HsExpr GhcTc),
  GenLocated SrcSpanAnnA (Pat GhcPs))]
patSplices
        , [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. [a] -> DList a
DL.fromList ([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
 -> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ ((GenLocated SrcSpanAnnA (HsExpr GhcTc),
  GenLocated SrcSpanAnnA (HsType GhcPs))
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsExpr GhcTc),
 GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a, b) -> a
fst [(XRec GhcTc (HsExpr GhcTc), LHsType GhcPs)]
[(GenLocated SrcSpanAnnA (HsExpr GhcTc),
  GenLocated SrcSpanAnnA (HsType GhcPs))]
typeSplices
        , [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. [a] -> DList a
DL.fromList ([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
 -> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ ((GenLocated SrcSpanAnnA (HsExpr GhcTc),
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [(GenLocated SrcSpanAnnA (HsExpr GhcTc),
     [GenLocated SrcSpanAnnA (HsDecl GhcPs)])]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsExpr GhcTc),
 [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a, b) -> a
fst [(XRec GhcTc (HsExpr GhcTc), [LHsDecl GhcPs])]
[(GenLocated SrcSpanAnnA (HsExpr GhcTc),
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)])]
declSplices
        , [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. [a] -> DList a
DL.fromList ([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
 -> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> DList (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [(GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsExpr GhcTc), Serialized)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a, b) -> a
fst [(XRec GhcTc (HsExpr GhcTc), Serialized)]
[(GenLocated SrcSpanAnnA (HsExpr 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 :: IdeOptions -> ProgressReportingStyle
optProgressStyle :: ProgressReportingStyle
optProgressStyle} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
se
 STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  HashMap NormalizedFilePath Fingerprint
pending <- TVar (HashMap NormalizedFilePath Fingerprint)
-> STM (HashMap NormalizedFilePath Fingerprint)
forall a. TVar a -> STM a
readTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending
  case NormalizedFilePath
-> HashMap NormalizedFilePath Fingerprint -> Maybe Fingerprint
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 Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
hash -> () -> STM ()
forall a. a -> STM a
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 = mempty}
      TVar (HashMap NormalizedFilePath Fingerprint)
-> (HashMap NormalizedFilePath Fingerprint
    -> HashMap NormalizedFilePath Fingerprint)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashMap NormalizedFilePath Fingerprint)
indexPending ((HashMap NormalizedFilePath Fingerprint
  -> HashMap NormalizedFilePath Fingerprint)
 -> STM ())
-> (HashMap NormalizedFilePath Fingerprint
    -> HashMap NormalizedFilePath Fingerprint)
-> STM ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> Fingerprint
-> HashMap NormalizedFilePath Fingerprint
-> HashMap NormalizedFilePath Fingerprint
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert NormalizedFilePath
srcPath Fingerprint
hash
      TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
-> (((HieDb -> IO ()) -> IO ()) -> IO ()) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
indexQueue ((((HieDb -> IO ()) -> IO ()) -> IO ()) -> STM ())
-> (((HieDb -> IO ()) -> IO ()) -> IO ()) -> STM ()
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 <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
          HashMap NormalizedFilePath Fingerprint
pendingOps <- TVar (HashMap NormalizedFilePath Fingerprint)
-> STM (HashMap NormalizedFilePath Fingerprint)
forall a. TVar a -> STM a
readTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending
          Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ case NormalizedFilePath
-> HashMap NormalizedFilePath Fingerprint -> Maybe Fingerprint
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 Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
hash
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newerScheduled (IO () -> IO ()) -> IO () -> IO ()
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.
          IO () -> IO () -> IO () -> IO ()
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> m b -> m c -> m c
bracket_ (ProgressReportingStyle -> IO ()
pre ProgressReportingStyle
optProgressStyle) IO ()
post (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            (HieDb -> IO ()) -> IO ()
withHieDb (\HieDb
db -> HieDb -> FilePath -> SourceFile -> Fingerprint -> HieFile -> IO ()
forall (m :: * -> *).
MonadIO m =>
HieDb -> FilePath -> SourceFile -> Fingerprint -> HieFile -> m ()
HieDb.addRefsFromLoaded HieDb
db FilePath
targetPath (FilePath -> SourceFile
HieDb.RealFile (FilePath -> SourceFile) -> FilePath -> SourceFile
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
srcPath) Fingerprint
hash HieFile
hf')
  where
    mod_location :: ModLocation
mod_location    = ModSummary -> ModLocation
ms_location ModSummary
mod_summary
    targetPath :: FilePath
targetPath      = ModLocation -> FilePath
Compat.ml_hie_file ModLocation
mod_location
    HieDbWriter{TVar Int
TVar (HashMap NormalizedFilePath Fingerprint)
Var (Maybe ProgressToken)
TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
indexPending :: HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
indexCompleted :: HieDbWriter -> TVar Int
indexPending :: TVar (HashMap NormalizedFilePath Fingerprint)
indexQueue :: TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
indexCompleted :: TVar Int
indexProgressToken :: Var (Maybe ProgressToken)
$sel:indexQueue:HieDbWriter :: HieDbWriter -> TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
$sel:indexProgressToken:HieDbWriter :: HieDbWriter -> Var (Maybe ProgressToken)
..} = 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 <- Var (Maybe ProgressToken)
-> (Maybe ProgressToken
    -> IO (Maybe ProgressToken, Maybe ProgressToken))
-> IO (Maybe ProgressToken)
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (Maybe ProgressToken)
indexProgressToken ((Maybe ProgressToken
  -> IO (Maybe ProgressToken, Maybe ProgressToken))
 -> IO (Maybe ProgressToken))
-> (Maybe ProgressToken
    -> IO (Maybe ProgressToken, Maybe ProgressToken))
-> IO (Maybe ProgressToken)
forall a b. (a -> b) -> a -> b
$ (Maybe ProgressToken -> (Maybe ProgressToken, Maybe ProgressToken))
-> IO (Maybe ProgressToken)
-> IO (Maybe ProgressToken, Maybe ProgressToken)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ProgressToken -> (Maybe ProgressToken, Maybe ProgressToken)
forall a. a -> (a, a)
dupe (IO (Maybe ProgressToken)
 -> IO (Maybe ProgressToken, Maybe ProgressToken))
-> (Maybe ProgressToken -> IO (Maybe ProgressToken))
-> Maybe ProgressToken
-> IO (Maybe ProgressToken, Maybe ProgressToken)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        x :: Maybe ProgressToken
x@(Just ProgressToken
_) -> Maybe ProgressToken -> IO (Maybe ProgressToken)
forall a. a -> IO a
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 -> Maybe ProgressToken -> IO (Maybe ProgressToken)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ProgressToken
forall a. Maybe a
Nothing
            Just LanguageContextEnv Config
env -> LanguageContextEnv Config
-> LspT Config IO (Maybe ProgressToken) -> IO (Maybe ProgressToken)
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO (Maybe ProgressToken) -> IO (Maybe ProgressToken))
-> LspT Config IO (Maybe ProgressToken) -> IO (Maybe ProgressToken)
forall a b. (a -> b) -> a -> b
$ do
              ProgressToken
u <- (Int32 |? Text) -> ProgressToken
LSP.ProgressToken ((Int32 |? Text) -> ProgressToken)
-> (Unique -> Int32 |? Text) -> Unique -> ProgressToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int32 |? Text
forall a b. b -> a |? b
LSP.InR (Text -> Int32 |? Text)
-> (Unique -> Text) -> Unique -> Int32 |? Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (Unique -> FilePath) -> Unique -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (Unique -> Int) -> Unique -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique (Unique -> ProgressToken)
-> LspT Config IO Unique -> LspT Config IO ProgressToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique -> LspT Config IO Unique
forall a. IO a -> LspT Config IO a
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
_ <- SServerMethod 'Method_WindowWorkDoneProgressCreate
-> MessageParams 'Method_WindowWorkDoneProgressCreate
-> (Either
      (TResponseError 'Method_WindowWorkDoneProgressCreate)
      (MessageResult 'Method_WindowWorkDoneProgressCreate)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'Method_WindowWorkDoneProgressCreate)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'Method_WindowWorkDoneProgressCreate
LSP.SMethod_WindowWorkDoneProgressCreate (ProgressToken -> WorkDoneProgressCreateParams
LSP.WorkDoneProgressCreateParams ProgressToken
u) (LspT Config IO ()
-> Either
     (TResponseError 'Method_WindowWorkDoneProgressCreate)
     (MessageResult 'Method_WindowWorkDoneProgressCreate)
-> LspT Config IO ()
forall a b. a -> b -> a
const (LspT Config IO ()
 -> Either
      (TResponseError 'Method_WindowWorkDoneProgressCreate)
      (MessageResult 'Method_WindowWorkDoneProgressCreate)
 -> LspT Config IO ())
-> LspT Config IO ()
-> Either
     (TResponseError 'Method_WindowWorkDoneProgressCreate)
     (MessageResult 'Method_WindowWorkDoneProgressCreate)
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ () -> LspT Config IO ()
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              SServerMethod 'Method_Progress
-> MessageParams 'Method_Progress -> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_Progress
forall {f :: MessageDirection}. SMethod 'Method_Progress
LSP.SMethod_Progress (MessageParams 'Method_Progress -> LspT Config IO ())
-> MessageParams 'Method_Progress -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
LSP.ProgressParams ProgressToken
u (Value -> ProgressParams) -> Value -> ProgressParams
forall a b. (a -> b) -> a -> b
$
                WorkDoneProgressBegin -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkDoneProgressBegin -> Value) -> WorkDoneProgressBegin -> Value
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 = Maybe Bool
forall a. Maybe a
Nothing
                  , $sel:_message:WorkDoneProgressBegin :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                  , $sel:_percentage:WorkDoneProgressBegin :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                  }
              Maybe ProgressToken -> LspT Config IO (Maybe ProgressToken)
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgressToken -> Maybe ProgressToken
forall a. a -> Maybe a
Just ProgressToken
u)

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

      Maybe (LanguageContextEnv Config)
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) ((LanguageContextEnv Config -> IO ()) -> IO ())
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env -> Maybe ProgressToken -> (ProgressToken -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProgressToken
tok ((ProgressToken -> IO ()) -> IO ())
-> (ProgressToken -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressToken
token -> LanguageContextEnv Config -> LspT Config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        SServerMethod 'Method_Progress
-> MessageParams 'Method_Progress -> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_Progress
forall {f :: MessageDirection}. SMethod 'Method_Progress
LSP.SMethod_Progress (MessageParams 'Method_Progress -> LspT Config IO ())
-> MessageParams 'Method_Progress -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
LSP.ProgressParams ProgressToken
token (Value -> ProgressParams) -> Value -> ProgressParams
forall a b. (a -> b) -> a -> b
$
          WorkDoneProgressReport -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkDoneProgressReport -> Value)
-> WorkDoneProgressReport -> Value
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 = Maybe Bool
forall a. Maybe a
Nothing
                    , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                    , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = UInt -> Maybe UInt
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 = Maybe Bool
forall a. Maybe a
Nothing
                    , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
                        FilePath -> Text
T.pack FilePath
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
done) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Int
done Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
remaining) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")..."
                    , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = Maybe UInt
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 = Maybe Bool
forall a. Maybe a
Nothing
                  , $sel:_message:WorkDoneProgressReport :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                  , $sel:_percentage:WorkDoneProgressReport :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                  }

    -- Report the progress once we are done indexing this file
    post :: IO ()
post = do
      Maybe Int
mdone <- STM (Maybe Int) -> IO (Maybe Int)
forall a. STM a -> IO a
atomically (STM (Maybe Int) -> IO (Maybe Int))
-> STM (Maybe Int) -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ do
        -- Remove current element from pending
        HashMap NormalizedFilePath Fingerprint
pending <- TVar (HashMap NormalizedFilePath Fingerprint)
-> (HashMap NormalizedFilePath Fingerprint
    -> (HashMap NormalizedFilePath Fingerprint,
        HashMap NormalizedFilePath Fingerprint))
-> STM (HashMap NormalizedFilePath Fingerprint)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending ((HashMap NormalizedFilePath Fingerprint
  -> (HashMap NormalizedFilePath Fingerprint,
      HashMap NormalizedFilePath Fingerprint))
 -> STM (HashMap NormalizedFilePath Fingerprint))
-> (HashMap NormalizedFilePath Fingerprint
    -> (HashMap NormalizedFilePath Fingerprint,
        HashMap NormalizedFilePath Fingerprint))
-> STM (HashMap NormalizedFilePath Fingerprint)
forall a b. (a -> b) -> a -> b
$
          HashMap NormalizedFilePath Fingerprint
-> (HashMap NormalizedFilePath Fingerprint,
    HashMap NormalizedFilePath Fingerprint)
forall a. a -> (a, a)
dupe (HashMap NormalizedFilePath Fingerprint
 -> (HashMap NormalizedFilePath Fingerprint,
     HashMap NormalizedFilePath Fingerprint))
-> (HashMap NormalizedFilePath Fingerprint
    -> HashMap NormalizedFilePath Fingerprint)
-> HashMap NormalizedFilePath Fingerprint
-> (HashMap NormalizedFilePath Fingerprint,
    HashMap NormalizedFilePath Fingerprint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fingerprint -> Maybe Fingerprint)
-> NormalizedFilePath
-> HashMap NormalizedFilePath Fingerprint
-> HashMap NormalizedFilePath Fingerprint
forall k a.
(Eq k, Hashable k) =>
(a -> Maybe a) -> k -> HashMap k a -> HashMap k a
HashMap.update (\Fingerprint
pendingHash -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Fingerprint
pendingHash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
hash) Maybe () -> Fingerprint -> Maybe Fingerprint
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Fingerprint
pendingHash) NormalizedFilePath
srcPath
        TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
indexCompleted (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        -- If we are done, report and reset completed
        Bool -> STM Int -> STM (Maybe Int)
forall (m :: * -> *) a. Applicative m => Bool -> m a -> m (Maybe a)
whenMaybe (HashMap NormalizedFilePath Fingerprint -> Bool
forall k v. HashMap k v -> Bool
HashMap.null HashMap NormalizedFilePath Fingerprint
pending) (STM Int -> STM (Maybe Int)) -> STM Int -> STM (Maybe Int)
forall a b. (a -> b) -> a -> b
$
          TVar Int -> Int -> STM Int
forall a. TVar a -> a -> STM a
swapTVar TVar Int
indexCompleted Int
0
      Maybe (LanguageContextEnv Config)
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) ((LanguageContextEnv Config -> IO ()) -> IO ())
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env -> LanguageContextEnv Config -> LspT Config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Bool -> LspT Config IO () -> LspT Config IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IdeTesting -> Bool
forall a b. Coercible a b => a -> b
coerce (IdeTesting -> Bool) -> IdeTesting -> Bool
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IdeTesting
ideTesting ShakeExtras
se) (LspT Config IO () -> LspT Config IO ())
-> LspT Config IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$
          SServerMethod ('Method_CustomMethod "ghcide/reference/ready")
-> MessageParams ('Method_CustomMethod "ghcide/reference/ready")
-> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (Proxy "ghcide/reference/ready"
-> SServerMethod ('Method_CustomMethod "ghcide/reference/ready")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
LSP.SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"ghcide/reference/ready")) (MessageParams ('Method_CustomMethod "ghcide/reference/ready")
 -> LspT Config IO ())
-> MessageParams ('Method_CustomMethod "ghcide/reference/ready")
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$
            FilePath -> Value
forall a. ToJSON a => a -> Value
toJSON (FilePath -> Value) -> FilePath -> Value
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
srcPath
      Maybe Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
mdone ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
done ->
        Var (Maybe ProgressToken)
-> (Maybe ProgressToken -> IO (Maybe ProgressToken)) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (Maybe ProgressToken)
indexProgressToken ((Maybe ProgressToken -> IO (Maybe ProgressToken)) -> IO ())
-> (Maybe ProgressToken -> IO (Maybe ProgressToken)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe ProgressToken
tok -> do
          Maybe (LanguageContextEnv Config)
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) ((LanguageContextEnv Config -> IO ()) -> IO ())
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env -> LanguageContextEnv Config -> LspT Config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Maybe ProgressToken
-> (ProgressToken -> LspT Config IO ()) -> LspT Config IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProgressToken
tok ((ProgressToken -> LspT Config IO ()) -> LspT Config IO ())
-> (ProgressToken -> LspT Config IO ()) -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressToken
token ->
              SServerMethod 'Method_Progress
-> MessageParams 'Method_Progress -> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_Progress
forall {f :: MessageDirection}. SMethod 'Method_Progress
LSP.SMethod_Progress  (MessageParams 'Method_Progress -> LspT Config IO ())
-> MessageParams 'Method_Progress -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
LSP.ProgressParams ProgressToken
token (Value -> ProgressParams) -> Value -> ProgressParams
forall a b. (a -> b) -> a -> b
$
                WorkDoneProgressEnd -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkDoneProgressEnd -> Value) -> WorkDoneProgressEnd -> Value
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 = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"Finished indexing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
done) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" files"
                  }
          -- We are done with the current indexing cycle, so destroy the token
          Maybe ProgressToken -> IO (Maybe ProgressToken)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ProgressToken
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" (IO () -> IO [FileDiagnostic]) -> IO () -> IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ do
    HieFile
hf <- HscEnv -> Hsc HieFile -> IO HieFile
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hscEnv (Hsc HieFile -> IO HieFile) -> Hsc HieFile -> IO HieFile
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
    ShakeExtras -> FilePath -> (FilePath -> IO ()) -> IO ()
forall a. ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
atomicFileWrite ShakeExtras
se FilePath
targetPath ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> HieFile -> IO ()) -> HieFile -> FilePath -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> HieFile -> IO ()
GHC.writeHieFile HieFile
hf
    Fingerprint
hash <- FilePath -> IO Fingerprint
Util.getFileHash FilePath
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 :: FilePath
targetPath   = ModLocation -> FilePath
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" (IO () -> IO [FileDiagnostic]) -> IO () -> IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ do
    ShakeExtras -> FilePath -> (FilePath -> IO ()) -> IO ()
forall a. ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
atomicFileWrite ShakeExtras
se FilePath
targetPath ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fp ->
      HscEnv -> FilePath -> ModIface_ 'ModIfaceFinal -> IO ()
writeIfaceFile HscEnv
hscEnv FilePath
fp ModIface_ 'ModIfaceFinal
modIface
  where
    modIface :: ModIface_ 'ModIfaceFinal
modIface = HiFileResult -> ModIface_ 'ModIfaceFinal
hirModIface HiFileResult
tc
    targetPath :: FilePath
targetPath = ModLocation -> FilePath
ml_hi_file (ModLocation -> FilePath) -> ModLocation -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation) -> ModSummary -> ModLocation
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 IO () -> IO [FileDiagnostic] -> IO [FileDiagnostic]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FileDiagnostic] -> IO [FileDiagnostic]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [] IO [FileDiagnostic]
-> [Handler IO [FileDiagnostic]] -> IO [FileDiagnostic]
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches`
    [ (GhcException -> IO [FileDiagnostic])
-> Handler IO [FileDiagnostic]
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((GhcException -> IO [FileDiagnostic])
 -> Handler IO [FileDiagnostic])
-> (GhcException -> IO [FileDiagnostic])
-> Handler IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> IO [FileDiagnostic]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic] -> IO [FileDiagnostic])
-> (GhcException -> [FileDiagnostic])
-> GhcException
-> IO [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
source DynFlags
dflags
    , (SomeException -> IO [FileDiagnostic])
-> Handler IO [FileDiagnostic]
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeException -> IO [FileDiagnostic])
 -> Handler IO [FileDiagnostic])
-> (SomeException -> IO [FileDiagnostic])
-> Handler IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> IO [FileDiagnostic]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic] -> IO [FileDiagnostic])
-> (SomeException -> [FileDiagnostic])
-> SomeException
-> IO [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> DiagnosticSeverity -> SrcSpan -> FilePath -> [FileDiagnostic]
diagFromString Text
source DiagnosticSeverity
DiagnosticSeverity_Error (FilePath -> SrcSpan
noSpan FilePath
"<internal>")
    (FilePath -> [FileDiagnostic])
-> (SomeException -> FilePath) -> SomeException -> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
"Error during " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
source) ++) (FilePath -> FilePath)
-> (SomeException -> FilePath) -> SomeException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
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 =
  (Maybe a -> ([FileDiagnostic], Maybe a))
-> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([],) IO (Maybe a)
action IO ([FileDiagnostic], Maybe a)
-> [Handler IO ([FileDiagnostic], Maybe a)]
-> IO ([FileDiagnostic], Maybe a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches`
    [ (GhcException -> IO ([FileDiagnostic], Maybe a))
-> Handler IO ([FileDiagnostic], Maybe a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((GhcException -> IO ([FileDiagnostic], Maybe a))
 -> Handler IO ([FileDiagnostic], Maybe a))
-> (GhcException -> IO ([FileDiagnostic], Maybe a))
-> Handler IO ([FileDiagnostic], Maybe a)
forall a b. (a -> b) -> a -> b
$ ([FileDiagnostic], Maybe a) -> IO ([FileDiagnostic], Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([FileDiagnostic], Maybe a) -> IO ([FileDiagnostic], Maybe a))
-> (GhcException -> ([FileDiagnostic], Maybe a))
-> GhcException
-> IO ([FileDiagnostic], Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Maybe a
forall a. Maybe a
Nothing) ([FileDiagnostic] -> ([FileDiagnostic], Maybe a))
-> (GhcException -> [FileDiagnostic])
-> GhcException
-> ([FileDiagnostic], Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
source DynFlags
dflags
    , (SomeException -> IO ([FileDiagnostic], Maybe a))
-> Handler IO ([FileDiagnostic], Maybe a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeException -> IO ([FileDiagnostic], Maybe a))
 -> Handler IO ([FileDiagnostic], Maybe a))
-> (SomeException -> IO ([FileDiagnostic], Maybe a))
-> Handler IO ([FileDiagnostic], Maybe a)
forall a b. (a -> b) -> a -> b
$ ([FileDiagnostic], Maybe a) -> IO ([FileDiagnostic], Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([FileDiagnostic], Maybe a) -> IO ([FileDiagnostic], Maybe a))
-> (SomeException -> ([FileDiagnostic], Maybe a))
-> SomeException
-> IO ([FileDiagnostic], Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Maybe a
forall a. Maybe a
Nothing) ([FileDiagnostic] -> ([FileDiagnostic], Maybe a))
-> (SomeException -> [FileDiagnostic])
-> SomeException
-> ([FileDiagnostic], Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> DiagnosticSeverity -> SrcSpan -> FilePath -> [FileDiagnostic]
diagFromString Text
source DiagnosticSeverity
DiagnosticSeverity_Error (FilePath -> SrcSpan
noSpan FilePath
"<internal>")
    (FilePath -> [FileDiagnostic])
-> (SomeException -> FilePath) -> SomeException -> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
"Error during " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
source) ++) (FilePath -> FilePath)
-> (SomeException -> FilePath) -> SomeException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
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 :: InstalledModule
im  = UnitId -> ModuleName -> InstalledModule
forall u. u -> ModuleName -> GenModule u
Compat.installedModule (Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms) (Module -> ModuleName
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
        curFinderCache :: FinderCacheState
curFinderCache = FinderCacheState
-> InstalledModule -> InstalledFindResult -> FinderCacheState
forall a.
InstalledModuleEnv a
-> InstalledModule -> a -> InstalledModuleEnv a
Compat.extendInstalledModuleEnv FinderCacheState
forall a. InstalledModuleEnv a
Compat.emptyInstalledModuleEnv InstalledModule
im InstalledFindResult
ifr
    FinderCache
newFinderCache <- FinderCacheState -> [FinderCache] -> IO FinderCache
concatFC FinderCacheState
curFinderCache ((HscEnv -> FinderCache) -> [HscEnv] -> [FinderCache]
forall a b. (a -> b) -> [a] -> [b]
map HscEnv -> FinderCache
hsc_FC [HscEnv]
envs)
    HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$! [HomeModInfo] -> HscEnv -> HscEnv
loadModulesHome [HomeModInfo]
extraMods (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$
      let newHug :: HomeUnitGraph
newHug = (HomeUnitGraph -> HomeUnitGraph -> HomeUnitGraph)
-> HomeUnitGraph -> [HomeUnitGraph] -> HomeUnitGraph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HomeUnitGraph -> HomeUnitGraph -> HomeUnitGraph
mergeHUG (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
env) ((HscEnv -> HomeUnitGraph) -> [HscEnv] -> [HomeUnitGraph]
forall a b. (a -> b) -> [a] -> [b]
map HscEnv -> HomeUnitGraph
hsc_HUG [HscEnv]
envs) in
      ((HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (HomeUnitGraph -> HomeUnitGraph -> HomeUnitGraph
forall a b. a -> b -> a
const HomeUnitGraph
newHug) HscEnv
env){
          hsc_FC = newFinderCache,
          hsc_mod_graph = mg
      }

    where
        mergeHUG :: HomeUnitGraph -> HomeUnitGraph -> HomeUnitGraph
mergeHUG (UnitEnvGraph Map UnitId HomeUnitEnv
a) (UnitEnvGraph Map UnitId HomeUnitEnv
b) = Map UnitId HomeUnitEnv -> HomeUnitGraph
forall v. Map UnitId v -> UnitEnvGraph v
UnitEnvGraph (Map UnitId HomeUnitEnv -> HomeUnitGraph)
-> Map UnitId HomeUnitEnv -> HomeUnitGraph
forall a b. (a -> b) -> a -> b
$ (HomeUnitEnv -> HomeUnitEnv -> HomeUnitEnv)
-> Map UnitId HomeUnitEnv
-> Map UnitId HomeUnitEnv
-> Map UnitId HomeUnitEnv
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith HomeUnitEnv -> HomeUnitEnv -> HomeUnitEnv
mergeHUE Map UnitId HomeUnitEnv
a Map UnitId HomeUnitEnv
b
        mergeHUE :: HomeUnitEnv -> HomeUnitEnv -> HomeUnitEnv
mergeHUE HomeUnitEnv
a HomeUnitEnv
b = HomeUnitEnv
a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }
        mergeUDFM :: UniqDFM key HomeModInfo
-> UniqDFM key HomeModInfo -> UniqDFM key HomeModInfo
mergeUDFM = (HomeModInfo -> HomeModInfo -> HomeModInfo)
-> UniqDFM key HomeModInfo
-> UniqDFM key HomeModInfo
-> UniqDFM key HomeModInfo
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 <- ModIface_ 'ModIfaceFinal -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
a) = HomeModInfo
a
          | Bool
otherwise = HomeModInfo
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 :: InstalledFindResult -> InstalledFindResult -> InstalledFindResult
combineModuleLocations a :: InstalledFindResult
a@(InstalledFound ModLocation
ml InstalledModule
_) InstalledFindResult
_ | Just FilePath
fp <- ModLocation -> Maybe FilePath
ml_hs_file ModLocation
ml, Bool -> Bool
not (FilePath
"boot" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fp) = InstalledFindResult
a
        combineModuleLocations InstalledFindResult
_ InstalledFindResult
b = InstalledFindResult
b

        concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache
        concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache
concatFC FinderCacheState
cur [FinderCache]
xs = do
          [FinderCacheState]
fcModules <- (FinderCache -> IO FinderCacheState)
-> [FinderCache] -> IO [FinderCacheState]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IORef FinderCacheState -> IO FinderCacheState
forall a. IORef a -> IO a
readIORef (IORef FinderCacheState -> IO FinderCacheState)
-> (FinderCache -> IORef FinderCacheState)
-> FinderCache
-> IO FinderCacheState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinderCache -> IORef FinderCacheState
fcModuleCache) [FinderCache]
xs
          [FileCacheState]
fcFiles <- (FinderCache -> IO FileCacheState)
-> [FinderCache] -> IO [FileCacheState]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IORef FileCacheState -> IO FileCacheState
forall a. IORef a -> IO a
readIORef (IORef FileCacheState -> IO FileCacheState)
-> (FinderCache -> IORef FileCacheState)
-> FinderCache
-> IO FileCacheState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinderCache -> IORef FileCacheState
fcFileCache) [FinderCache]
xs
          IORef FinderCacheState
fcModules' <- FinderCacheState -> IO (IORef FinderCacheState)
forall a. a -> IO (IORef a)
newIORef (FinderCacheState -> IO (IORef FinderCacheState))
-> FinderCacheState -> IO (IORef FinderCacheState)
forall a b. (a -> b) -> a -> b
$! (FinderCacheState -> FinderCacheState -> FinderCacheState)
-> FinderCacheState -> [FinderCacheState] -> FinderCacheState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((InstalledFindResult -> InstalledFindResult -> InstalledFindResult)
-> FinderCacheState -> FinderCacheState -> FinderCacheState
forall elt.
(elt -> elt -> elt)
-> InstalledModuleEnv elt
-> InstalledModuleEnv elt
-> InstalledModuleEnv elt
plusInstalledModuleEnv InstalledFindResult -> InstalledFindResult -> InstalledFindResult
combineModuleLocations) FinderCacheState
cur [FinderCacheState]
fcModules
          IORef FileCacheState
fcFiles' <- FileCacheState -> IO (IORef FileCacheState)
forall a. a -> IO (IORef a)
newIORef (FileCacheState -> IO (IORef FileCacheState))
-> FileCacheState -> IO (IORef FileCacheState)
forall a b. (a -> b) -> a -> b
$! [FileCacheState] -> FileCacheState
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [FileCacheState]
fcFiles
          FinderCache -> IO FinderCache
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FinderCache -> IO FinderCache) -> FinderCache -> IO FinderCache
forall a b. (a -> b) -> a -> b
$ IORef FinderCacheState -> IORef FileCacheState -> FinderCache
FinderCache IORef FinderCacheState
fcModules' IORef FileCacheState
fcFiles'

#else
    prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
        ifr = InstalledFound (ms_location ms) im
    newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr
    return $! loadModulesHome extraMods $
      env{
          hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
          hsc_FC = newFinderCache,
          hsc_mod_graph = mg
      }

    where
        mergeUDFM = plusUDFM_C combineModules
        combineModules a b
          | HsSrcFile <- mi_hsc_src (hm_iface a) = a
          | otherwise = 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 = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult))
#endif

withBootSuffix :: HscSource -> ModLocation -> ModLocation
withBootSuffix :: HscSource -> ModLocation -> ModLocation
withBootSuffix HscSource
HsBootFile = ModLocation -> ModLocation
addBootSuffixLocnOut
withBootSuffix HscSource
_          = ModLocation -> ModLocation
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
-> FilePath
-> UTCTime
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO ModSummaryResult
getModSummaryFromImports HscEnv
env FilePath
fp UTCTime
_modTime Maybe StringBuffer
mContents = do
-- src_hash is only used in GHC >= 9.4
    (StringBuffer
contents, [FilePath]
opts, HscEnv
ppEnv, Fingerprint
_src_hash) <- HscEnv
-> FilePath
-> Maybe StringBuffer
-> ExceptT
     [FileDiagnostic] IO (StringBuffer, [FilePath], HscEnv, Fingerprint)
preprocessor HscEnv
env FilePath
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 GhcPs
hsmod) <- DynFlags
-> FilePath
-> StringBuffer
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedSource)
forall (m :: * -> *).
Monad m =>
DynFlags
-> FilePath
-> StringBuffer
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
parseHeader DynFlags
dflags FilePath
fp StringBuffer
contents

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

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

        ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
    [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IsBootInterface -> Bool)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> IsBootInterface)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclSource(ImportDecl GhcPs -> IsBootInterface)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
.GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl 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)
          = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
    [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM) (ModuleName -> Bool)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc
                      (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
    -> GenLocated SrcSpanAnnA ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> XRec GhcPs ModuleName
ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs
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)
-> (ImportDeclPkgQual pass, GenLocated SrcSpan ModuleName)
convImport (L l
_ ImportDecl pass
i) = (
#if !MIN_VERSION_ghc(9,3,0)
                               fmap sl_fs
#endif
                               (ImportDecl pass -> ImportDeclPkgQual pass
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl pass
i)
                             , GenLocated (SrcAnn a) ModuleName -> GenLocated SrcSpan ModuleName
forall a e. LocatedAn a e -> Located e
reLoc (GenLocated (SrcAnn a) ModuleName -> GenLocated SrcSpan ModuleName)
-> GenLocated (SrcAnn a) ModuleName
-> GenLocated SrcSpan ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl pass -> XRec pass ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
i)

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

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


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


    ModLocation
modLoc <- IO ModLocation -> ExceptT [FileDiagnostic] IO ModLocation
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> ExceptT [FileDiagnostic] IO ModLocation)
-> IO ModLocation -> ExceptT [FileDiagnostic] IO ModLocation
forall a b. (a -> b) -> a -> b
$ if ModuleName
mod ModuleName -> ModuleName -> Bool
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 -> FilePath -> IO ModLocation
mkHomeModLocation DynFlags
dflags (FilePath -> ModuleName
pathToModuleName FilePath
fp) FilePath
fp
        else DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation DynFlags
dflags ModuleName
mod FilePath
fp

    let modl :: Module
modl = HomeUnit -> ModuleName -> Module
mkHomeModule (HscEnv -> HomeUnit
hscHomeUnit HscEnv
ppEnv) ModuleName
mod
        sourceType :: HscSource
sourceType = if FilePath
"-boot" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath -> FilePath
takeExtension FilePath
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     = Maybe UTCTime
forall a. Maybe a
Nothing
#if MIN_VERSION_ghc(9,3,0)
                , ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date    = Maybe UTCTime
forall a. Maybe a
Nothing
                , ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool
ghc_prim_import
                , ms_hs_hash :: Fingerprint
ms_hs_hash      = Fingerprint
_src_hash

#else
                , ms_hs_date      = _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     = StringBuffer -> Maybe StringBuffer
forall a. a -> Maybe a
Just StringBuffer
contents
                , ms_hspp_file :: FilePath
ms_hspp_file    = FilePath
fp
                , ms_hspp_opts :: DynFlags
ms_hspp_opts    = DynFlags
dflags
                , ms_iface_date :: Maybe UTCTime
ms_iface_date   = Maybe UTCTime
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     = Maybe UTCTime
forall a. Maybe a
Nothing
                , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod   = Maybe HsParsedModule
forall a. Maybe a
Nothing
                , ms_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps      = [(PkgQual, GenLocated SrcSpan ModuleName)]
srcImports
                , ms_textual_imps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps = [(PkgQual, GenLocated SrcSpan ModuleName)]
textualImports
                }

    Fingerprint
msrFingerprint <- IO Fingerprint -> ExceptT [FileDiagnostic] IO Fingerprint
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> ExceptT [FileDiagnostic] IO Fingerprint)
-> IO Fingerprint -> ExceptT [FileDiagnostic] IO Fingerprint
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ModSummary -> IO Fingerprint
computeFingerprint [FilePath]
opts ModSummary
msrModSummary2
    (ModSummary
msrModSummary, HscEnv
msrHscEnv) <- IO (ModSummary, HscEnv)
-> ExceptT [FileDiagnostic] IO (ModSummary, HscEnv)
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModSummary, HscEnv)
 -> ExceptT [FileDiagnostic] IO (ModSummary, HscEnv))
-> IO (ModSummary, HscEnv)
-> ExceptT [FileDiagnostic] IO (ModSummary, HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> IO (ModSummary, HscEnv)
initPlugins HscEnv
ppEnv ModSummary
msrModSummary2
    ModSummaryResult -> ExceptT [FileDiagnostic] IO ModSummaryResult
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummaryResult{[LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
Fingerprint
ModSummary
HscEnv
msrImports :: [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
msrFingerprint :: Fingerprint
msrModSummary :: ModSummary
msrHscEnv :: HscEnv
msrModSummary :: ModSummary
msrImports :: [LImportDecl GhcPs]
msrFingerprint :: Fingerprint
msrHscEnv :: HscEnv
..}
    where
        -- Compute a fingerprint from the contents of `ModSummary`,
        -- eliding the timestamps, the preprocessed source and other non relevant fields
        computeFingerprint :: [FilePath] -> ModSummary -> IO Fingerprint
computeFingerprint [FilePath]
opts ModSummary{Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
Maybe UTCTime
Maybe StringBuffer
Maybe HsParsedModule
Fingerprint
Module
ModLocation
HscSource
DynFlags
ms_hspp_opts :: ModSummary -> DynFlags
ms_location :: ModSummary -> ModLocation
ms_mod :: ModSummary -> Module
ms_hie_date :: ModSummary -> Maybe UTCTime
ms_dyn_obj_date :: ModSummary -> Maybe UTCTime
ms_ghc_prim_import :: ModSummary -> Bool
ms_hs_hash :: ModSummary -> Fingerprint
ms_hsc_src :: ModSummary -> HscSource
ms_hspp_buf :: ModSummary -> Maybe StringBuffer
ms_hspp_file :: ModSummary -> FilePath
ms_iface_date :: ModSummary -> Maybe UTCTime
ms_obj_date :: ModSummary -> Maybe UTCTime
ms_parsed_mod :: ModSummary -> Maybe HsParsedModule
ms_srcimps :: ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps :: ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_mod :: Module
ms_hsc_src :: HscSource
ms_location :: ModLocation
ms_hs_hash :: Fingerprint
ms_obj_date :: Maybe UTCTime
ms_dyn_obj_date :: Maybe UTCTime
ms_iface_date :: Maybe UTCTime
ms_hie_date :: Maybe UTCTime
ms_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_ghc_prim_import :: Bool
ms_parsed_mod :: Maybe HsParsedModule
ms_hspp_file :: FilePath
ms_hspp_opts :: DynFlags
ms_hspp_buf :: Maybe StringBuffer
..} = do
            Fingerprint
fingerPrintImports <- Put -> IO Fingerprint
fingerprintFromPut (Put -> IO Fingerprint) -> Put -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ do
                  Int -> Put
forall t. Binary t => t -> Put
put (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ FastString -> Int
Util.uniq (FastString -> Int) -> FastString -> Int
forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
moduleNameFS (ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
ms_mod
                  [(PkgQual, GenLocated SrcSpan ModuleName)]
-> ((PkgQual, GenLocated SrcSpan ModuleName) -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps) (((PkgQual, GenLocated SrcSpan ModuleName) -> Put) -> Put)
-> ((PkgQual, GenLocated SrcSpan ModuleName) -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \(PkgQual
mb_p, GenLocated SrcSpan ModuleName
m) -> do
                    Int -> Put
forall t. Binary t => t -> Put
put (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ FastString -> Int
Util.uniq (FastString -> Int) -> FastString -> Int
forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
moduleNameFS (ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
m
#if MIN_VERSION_ghc(9,3,0)
                    case PkgQual
mb_p of
                      PkgQual
G.NoPkgQual -> () -> Put
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      G.ThisPkg UnitId
uid  -> Int -> Put
forall t. Binary t => t -> Put
put (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ Unique -> Int
getKey (Unique -> Int) -> Unique -> Int
forall a b. (a -> b) -> a -> b
$ UnitId -> Unique
forall a. Uniquable a => a -> Unique
getUnique UnitId
uid
                      G.OtherPkg UnitId
uid -> Int -> Put
forall t. Binary t => t -> Put
put (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ Unique -> Int
getKey (Unique -> Int) -> Unique -> Int
forall a b. (a -> b) -> a -> b
$ UnitId -> Unique
forall a. Uniquable a => a -> Unique
getUnique UnitId
uid
#else
                    whenJust mb_p $ put . Util.uniq
#endif
            Fingerprint -> IO Fingerprint
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$! [Fingerprint] -> Fingerprint
Util.fingerprintFingerprints ([Fingerprint] -> Fingerprint) -> [Fingerprint] -> Fingerprint
forall a b. (a -> b) -> a -> b
$
                    [ FilePath -> Fingerprint
Util.fingerprintString FilePath
fp
                    , Fingerprint
fingerPrintImports
                    ] [Fingerprint] -> [Fingerprint] -> [Fingerprint]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Fingerprint) -> [FilePath] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Fingerprint
Util.fingerprintString [FilePath]
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
-> FilePath
-> StringBuffer
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
parseHeader DynFlags
dflags FilePath
filename StringBuffer
contents = do
   let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
Util.mkFastString FilePath
filename) Int
1 Int
1
   case P ParsedSource -> PState -> ParseResult ParsedSource
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 ->
        [FileDiagnostic]
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([FileDiagnostic]
 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource))
-> [FileDiagnostic]
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
forall a b. (a -> b) -> a -> b
$ Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags (Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic])
-> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
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) = PsMessages
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
renderMessages (PsMessages
 -> (Bag (MsgEnvelope DecoratedSDoc),
     Bag (MsgEnvelope DecoratedSDoc)))
-> PsMessages
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
forall a b. (a -> b) -> a -> b
$ PState -> PsMessages
getPsMessages PState
pst

        -- 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.
        Bool
-> ExceptT [FileDiagnostic] m () -> ExceptT [FileDiagnostic] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag (MsgEnvelope DecoratedSDoc) -> Bool
forall a. Bag a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag (MsgEnvelope DecoratedSDoc)
errs) (ExceptT [FileDiagnostic] m () -> ExceptT [FileDiagnostic] m ())
-> ExceptT [FileDiagnostic] m () -> ExceptT [FileDiagnostic] m ()
forall a b. (a -> b) -> a -> b
$
            [FileDiagnostic] -> ExceptT [FileDiagnostic] m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([FileDiagnostic] -> ExceptT [FileDiagnostic] m ())
-> [FileDiagnostic] -> ExceptT [FileDiagnostic] m ()
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
        ([FileDiagnostic], ParsedSource)
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
forall a. a -> ExceptT [FileDiagnostic] m a
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)
-> FilePath
-> ModSummary
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
parseFileContents HscEnv
env ParsedSource -> IdePreprocessedSource
customPreprocessor FilePath
filename ModSummary
ms = do
   let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
Util.mkFastString FilePath
filename) Int
1 Int
1
       dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
       contents :: StringBuffer
contents = Maybe StringBuffer -> StringBuffer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe StringBuffer -> StringBuffer)
-> Maybe StringBuffer -> StringBuffer
forall a b. (a -> b) -> a -> b
$ ModSummary -> Maybe StringBuffer
ms_hspp_buf ModSummary
ms
   case P ParsedSource -> PState -> ParseResult ParsedSource
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 -> [FileDiagnostic]
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([FileDiagnostic]
 -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule))
-> [FileDiagnostic]
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
forall a b. (a -> b) -> a -> b
$ Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags (Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic])
-> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
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 :: PsMessages
psMessages = PState -> PsMessages
getPsMessages PState
pst
         in
           do
               let IdePreprocessedSource [(SrcSpan, FilePath)]
preproc_warns [(SrcSpan, FilePath)]
errs ParsedSource
parsed = ParsedSource -> IdePreprocessedSource
customPreprocessor ParsedSource
rdr_module

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

               let preproc_warnings :: [FileDiagnostic]
preproc_warnings = Text
-> DiagnosticSeverity -> [(SrcSpan, FilePath)] -> [FileDiagnostic]
diagFromStrings Text
sourceParser DiagnosticSeverity
DiagnosticSeverity_Warning [(SrcSpan, FilePath)]
preproc_warns
               (ParsedSource
parsed', PsMessages
msgs) <- IO (ParsedSource, PsMessages)
-> ExceptT [FileDiagnostic] IO (ParsedSource, PsMessages)
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ParsedSource, PsMessages)
 -> ExceptT [FileDiagnostic] IO (ParsedSource, PsMessages))
-> IO (ParsedSource, PsMessages)
-> ExceptT [FileDiagnostic] IO (ParsedSource, PsMessages)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> ()
-> ParsedSource
-> PsMessages
-> IO (ParsedSource, PsMessages)
applyPluginsParsedResultAction HscEnv
env ModSummary
ms ()
hpm_annotations ParsedSource
parsed PsMessages
psMessages
               let (Bag (MsgEnvelope DecoratedSDoc)
warns, Bag (MsgEnvelope DecoratedSDoc)
errors) = PsMessages
-> (Bag (MsgEnvelope DecoratedSDoc),
    Bag (MsgEnvelope DecoratedSDoc))
renderMessages PsMessages
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.
               Bool
-> ExceptT [FileDiagnostic] IO () -> ExceptT [FileDiagnostic] IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag (MsgEnvelope DecoratedSDoc) -> Bool
forall a. Bag a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag (MsgEnvelope DecoratedSDoc)
errors) (ExceptT [FileDiagnostic] IO () -> ExceptT [FileDiagnostic] IO ())
-> ExceptT [FileDiagnostic] IO () -> ExceptT [FileDiagnostic] IO ()
forall a b. (a -> b) -> a -> b
$
                 [FileDiagnostic] -> ExceptT [FileDiagnostic] IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([FileDiagnostic] -> ExceptT [FileDiagnostic] IO ())
-> [FileDiagnostic] -> ExceptT [FileDiagnostic] IO ()
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 :: FilePath
n_hspp  = FilePath -> FilePath
normalise FilePath
filename
#if MIN_VERSION_ghc(9,3,0)
                   TempDir FilePath
tmp_dir = DynFlags -> TempDir
tmpDir DynFlags
dflags
#else
                   tmp_dir = tmpDir dflags
#endif
                   srcs0 :: [FilePath]
srcs0 = [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
nubOrd ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
tmp_dir `isPrefixOf`))
                                  ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
n_hspp)
                                  ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalise
                                  ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"<")
                                  ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FastString -> FilePath) -> [FastString] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> FilePath
Util.unpackFS
                                  ([FastString] -> [FilePath]) -> [FastString] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ PState -> [FastString]
srcfiles PState
pst
                   srcs1 :: [FilePath]
srcs1 = case ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms) of
                             Just FilePath
f  -> (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath -> FilePath
normalise FilePath
f) [FilePath]
srcs0
                             Maybe FilePath
Nothing -> [FilePath]
srcs0

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

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

loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
loadHieFile :: NameCacheUpdater -> FilePath -> IO HieFile
loadHieFile NameCacheUpdater
ncu FilePath
f = do
  HieFileResult -> HieFile
GHC.hie_file_result (HieFileResult -> HieFile) -> IO HieFileResult -> IO HieFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameCacheUpdater -> FilePath -> IO HieFileResult
GHC.readHieFile NameCacheUpdater
ncu FilePath
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)      = Linkable -> ()
forall a. NFData a => a -> ()
rnf Linkable
lb
  rnf (CoreLinkable UTCTime
time CoreFile
_) = UTCTime -> ()
forall a. NFData a => a -> ()
rnf UTCTime
time

ml_core_file :: ModLocation -> FilePath
ml_core_file :: ModLocation -> FilePath
ml_core_file ModLocation
ml = ModLocation -> FilePath
ml_hi_file ModLocation
ml FilePath -> FilePath -> FilePath
<.> FilePath
"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)
source_version :: forall (m :: * -> *). RecompilationInfo m -> FileVersion
old_value :: forall (m :: * -> *).
RecompilationInfo m -> Maybe (HiFileResult, FileVersion)
get_file_version :: forall (m :: * -> *).
RecompilationInfo m -> NormalizedFilePath -> m (Maybe FileVersion)
get_linkable_hashes :: forall (m :: * -> *).
RecompilationInfo m -> [NormalizedFilePath] -> m [ByteString]
regenerate :: forall (m :: * -> *).
RecompilationInfo m
-> Maybe LinkableType -> m (IdeResult HiFileResult)
source_version :: FileVersion
old_value :: Maybe (HiFileResult, FileVersion)
get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)
get_linkable_hashes :: [NormalizedFilePath] -> m [ByteString]
regenerate :: Maybe LinkableType -> m (IdeResult HiFileResult)
..} = do
    let sessionWithMsDynFlags :: HscEnv
sessionWithMsDynFlags = DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
session
        mb_old_iface :: Maybe (ModIface_ 'ModIfaceFinal)
mb_old_iface = HiFileResult -> ModIface_ 'ModIfaceFinal
hirModIface (HiFileResult -> ModIface_ 'ModIfaceFinal)
-> ((HiFileResult, FileVersion) -> HiFileResult)
-> (HiFileResult, FileVersion)
-> ModIface_ 'ModIfaceFinal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HiFileResult, FileVersion) -> HiFileResult
forall a b. (a, b) -> a
fst ((HiFileResult, FileVersion) -> ModIface_ 'ModIfaceFinal)
-> Maybe (HiFileResult, FileVersion)
-> Maybe (ModIface_ 'ModIfaceFinal)
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 = (HiFileResult, FileVersion) -> FileVersion
forall a b. (a, b) -> b
snd ((HiFileResult, FileVersion) -> FileVersion)
-> Maybe (HiFileResult, FileVersion) -> Maybe FileVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HiFileResult, FileVersion)
old_value

        core_file :: FilePath
core_file = ModLocation -> FilePath
ml_core_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
        iface_file :: FilePath
iface_file = ModLocation -> FilePath
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 -> Maybe FileVersion -> m (Maybe FileVersion)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FileVersion -> m (Maybe FileVersion))
-> Maybe FileVersion -> m (Maybe FileVersion)
forall a b. (a -> b) -> a -> b
$ FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just FileVersion
ver
      Maybe FileVersion
Nothing  -> NormalizedFilePath -> m (Maybe FileVersion)
get_file_version (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
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 FileVersion -> FileVersion -> Bool
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_ 'ModIfaceFinal)
_old_iface <- case Maybe (ModIface_ 'ModIfaceFinal)
mb_old_iface of
      Just ModIface_ 'ModIfaceFinal
iface -> Maybe (ModIface_ 'ModIfaceFinal)
-> m (Maybe (ModIface_ 'ModIfaceFinal))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just ModIface_ 'ModIfaceFinal
iface)
      Maybe (ModIface_ 'ModIfaceFinal)
Nothing -> do
        -- ncu and read_dflags are only used in GHC >= 9.4
        let _ncu :: NameCacheUpdater
_ncu = HscEnv -> NameCacheUpdater
hsc_NC HscEnv
sessionWithMsDynFlags
            _read_dflags :: DynFlags
_read_dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
sessionWithMsDynFlags
#if MIN_VERSION_ghc(9,3,0)
        MaybeErr SDoc (ModIface_ 'ModIfaceFinal)
read_result <- IO (MaybeErr SDoc (ModIface_ 'ModIfaceFinal))
-> m (MaybeErr SDoc (ModIface_ 'ModIfaceFinal))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MaybeErr SDoc (ModIface_ 'ModIfaceFinal))
 -> m (MaybeErr SDoc (ModIface_ 'ModIfaceFinal)))
-> IO (MaybeErr SDoc (ModIface_ 'ModIfaceFinal))
-> m (MaybeErr SDoc (ModIface_ 'ModIfaceFinal))
forall a b. (a -> b) -> a -> b
$ DynFlags
-> NameCacheUpdater
-> Module
-> FilePath
-> IO (MaybeErr SDoc (ModIface_ 'ModIfaceFinal))
readIface DynFlags
_read_dflags NameCacheUpdater
_ncu Module
mod FilePath
iface_file
#else
        read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags
                              $ readIface mod iface_file
#endif
        case MaybeErr SDoc (ModIface_ 'ModIfaceFinal)
read_result of
          Util.Failed{} -> Maybe (ModIface_ 'ModIfaceFinal)
-> m (Maybe (ModIface_ 'ModIfaceFinal))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ModIface_ 'ModIfaceFinal)
forall a. Maybe a
Nothing
          -- important to call `shareUsages` here before checkOldIface
          -- consults `mi_usages`
          Util.Succeeded ModIface_ 'ModIfaceFinal
iface -> Maybe (ModIface_ 'ModIfaceFinal)
-> m (Maybe (ModIface_ 'ModIfaceFinal))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ModIface_ 'ModIfaceFinal)
 -> m (Maybe (ModIface_ 'ModIfaceFinal)))
-> Maybe (ModIface_ 'ModIfaceFinal)
-> m (Maybe (ModIface_ 'ModIfaceFinal))
forall a b. (a -> b) -> a -> b
$ ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just (ModIface_ 'ModIfaceFinal -> ModIface_ 'ModIfaceFinal
shareUsages ModIface_ 'ModIfaceFinal
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_ 'ModIfaceFinal)
mb_checked_iface)
#if MIN_VERSION_ghc(9,3,0)
      <- IO (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
-> m (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
 -> m (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal)))
-> IO (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
-> m (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> Maybe (ModIface_ 'ModIfaceFinal)
-> IO (MaybeValidated (ModIface_ 'ModIfaceFinal))
checkOldIface HscEnv
sessionWithMsDynFlags ModSummary
ms Maybe (ModIface_ 'ModIfaceFinal)
_old_iface IO (MaybeValidated (ModIface_ 'ModIfaceFinal))
-> (MaybeValidated (ModIface_ 'ModIfaceFinal)
    -> IO (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal)))
-> IO (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        UpToDateItem ModIface_ 'ModIfaceFinal
x -> (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
-> IO (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecompileRequired
UpToDate, ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just ModIface_ 'ModIfaceFinal
x)
        OutOfDateItem CompileReason
reason Maybe (ModIface_ 'ModIfaceFinal)
x -> (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
-> IO (RecompileRequired, Maybe (ModIface_ 'ModIfaceFinal))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompileReason -> RecompileRequired
NeedsRecompile CompileReason
reason, Maybe (ModIface_ 'ModIfaceFinal)
x)
#else
      <- liftIO $ checkOldIface sessionWithMsDynFlags ms _sourceMod mb_old_iface
#endif

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

    case (Maybe (ModIface_ 'ModIfaceFinal)
mb_checked_iface, RecompileRequired
recomp_iface_reqd) of
      (Just ModIface_ 'ModIfaceFinal
iface, RecompileRequired
UpToDate) -> do
             ModDetails
details <- IO ModDetails -> m ModDetails
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModDetails -> m ModDetails) -> IO ModDetails -> m ModDetails
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModIface_ 'ModIfaceFinal -> IO ModDetails
mkDetailsFromIface HscEnv
sessionWithMsDynFlags ModIface_ 'ModIfaceFinal
iface
             -- parse the runtime dependencies from the annotations
             let runtime_deps :: ModuleEnv ByteString
runtime_deps
                   | Bool -> Bool
not (ModIface_ 'ModIfaceFinal -> Bool
forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th ModIface_ 'ModIfaceFinal
iface) = ModuleEnv ByteString
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 <- HscEnv
-> ([NormalizedFilePath] -> m [ByteString])
-> ModuleEnv ByteString
-> m (Maybe RecompileRequired)
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
                 | Maybe LinkableType -> Bool
forall a. Maybe a -> Bool
isJust Maybe LinkableType
linkableNeeded -> m (IdeResult HiFileResult) -> m (IdeResult HiFileResult)
handleErrs (m (IdeResult HiFileResult) -> m (IdeResult HiFileResult))
-> m (IdeResult HiFileResult) -> m (IdeResult HiFileResult)
forall a b. (a -> b) -> a -> b
$ do
                   (coreFile :: CoreFile
coreFile@CoreFile{Fingerprint
cf_iface_hash :: Fingerprint
cf_iface_hash :: CoreFile -> Fingerprint
cf_iface_hash}, Fingerprint
core_hash) <- IO (CoreFile, Fingerprint) -> m (CoreFile, Fingerprint)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CoreFile, Fingerprint) -> m (CoreFile, Fingerprint))
-> IO (CoreFile, Fingerprint) -> m (CoreFile, Fingerprint)
forall a b. (a -> b) -> a -> b
$
                     NameCacheUpdater -> FilePath -> IO (CoreFile, Fingerprint)
readBinCoreFile (NameCacheUpdater -> NameCacheUpdater
mkUpdater (NameCacheUpdater -> NameCacheUpdater)
-> NameCacheUpdater -> NameCacheUpdater
forall a b. (a -> b) -> a -> b
$ HscEnv -> NameCacheUpdater
hsc_NC HscEnv
session) FilePath
core_file
                   if Fingerprint
cf_iface_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== ModIface_ 'ModIfaceFinal -> Fingerprint
getModuleHash ModIface_ 'ModIfaceFinal
iface
                   then IdeResult HiFileResult -> m (IdeResult HiFileResult)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], HiFileResult -> Maybe HiFileResult
forall a. a -> Maybe a
Just (HiFileResult -> Maybe HiFileResult)
-> HiFileResult -> Maybe HiFileResult
forall a b. (a -> b) -> a -> b
$ ModSummary
-> ModIface_ 'ModIfaceFinal
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface_ 'ModIfaceFinal
iface ModDetails
details ModuleEnv ByteString
runtime_deps ((CoreFile, ByteString) -> Maybe (CoreFile, ByteString)
forall a. a -> Maybe a
Just (CoreFile
coreFile, Fingerprint -> ByteString
fingerprintToBS Fingerprint
core_hash)))
                   else RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate (FilePath -> RecompileRequired
recompBecause FilePath
"Core file out of date (doesn't match iface hash)")
                 | Bool
otherwise -> IdeResult HiFileResult -> m (IdeResult HiFileResult)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], HiFileResult -> Maybe HiFileResult
forall a. a -> Maybe a
Just (HiFileResult -> Maybe HiFileResult)
-> HiFileResult -> Maybe HiFileResult
forall a b. (a -> b) -> a -> b
$ ModSummary
-> ModIface_ 'ModIfaceFinal
-> ModDetails
-> ModuleEnv ByteString
-> Maybe (CoreFile, ByteString)
-> HiFileResult
mkHiFileResult ModSummary
ms ModIface_ 'ModIfaceFinal
iface ModDetails
details ModuleEnv ByteString
runtime_deps Maybe (CoreFile, ByteString)
forall a. Maybe a
Nothing)
                 where handleErrs :: m (IdeResult HiFileResult) -> m (IdeResult HiFileResult)
handleErrs = (m (IdeResult HiFileResult)
 -> [Handler m (IdeResult HiFileResult)]
 -> m (IdeResult HiFileResult))
-> [Handler m (IdeResult HiFileResult)]
-> m (IdeResult HiFileResult)
-> m (IdeResult HiFileResult)
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (IdeResult HiFileResult)
-> [Handler m (IdeResult HiFileResult)]
-> m (IdeResult HiFileResult)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
catches
                         [(IOException -> m (IdeResult HiFileResult))
-> Handler m (IdeResult HiFileResult)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException -> m (IdeResult HiFileResult))
 -> Handler m (IdeResult HiFileResult))
-> (IOException -> m (IdeResult HiFileResult))
-> Handler m (IdeResult HiFileResult)
forall a b. (a -> b) -> a -> b
$ \(IOException
e :: IOException) -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate (FilePath -> RecompileRequired
recompBecause (FilePath -> RecompileRequired) -> FilePath -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ FilePath
"Reading core file failed (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")")
                         ,(GhcException -> m (IdeResult HiFileResult))
-> Handler m (IdeResult HiFileResult)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((GhcException -> m (IdeResult HiFileResult))
 -> Handler m (IdeResult HiFileResult))
-> (GhcException -> m (IdeResult HiFileResult))
-> Handler m (IdeResult HiFileResult)
forall a b. (a -> b) -> a -> b
$ \(GhcException
e :: GhcException) -> case GhcException
e of
                            Signal Int
_ -> GhcException -> m (IdeResult HiFileResult)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw GhcException
e
                            Panic FilePath
_  -> GhcException -> m (IdeResult HiFileResult)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw GhcException
e
                            GhcException
_        -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate (FilePath -> RecompileRequired
recompBecause (FilePath -> RecompileRequired) -> FilePath -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ FilePath
"Reading core file failed (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ GhcException -> FilePath
forall a. Show a => a -> FilePath
show GhcException
e FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")")
                         ]
      (Maybe (ModIface_ 'ModIfaceFinal)
_, 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 = [(Module, ByteString)] -> ModuleEnv ByteString
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv ([(Module, ByteString)] -> ModuleEnv ByteString)
-> [(Module, ByteString)] -> ModuleEnv ByteString
forall a b. (a -> b) -> a -> b
$ (Annotation -> Maybe (Module, ByteString))
-> [Annotation] -> [(Module, ByteString)]
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 <- ([Word8] -> ByteString) -> Serialized -> Maybe ByteString
forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized [Word8] -> ByteString
BS.pack Serialized
payload
      = (Module, ByteString) -> Maybe (Module, ByteString)
forall a. a -> Maybe a
Just (Module
mod, ByteString
bs)
    go Annotation
_ = Maybe (Module, ByteString)
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)
  FinderCacheState
moduleLocs <- IO FinderCacheState -> m FinderCacheState
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FinderCacheState -> m FinderCacheState)
-> IO FinderCacheState -> m FinderCacheState
forall a b. (a -> b) -> a -> b
$ IORef FinderCacheState -> IO FinderCacheState
forall a. IORef a -> IO a
readIORef (FinderCache -> IORef FinderCacheState
fcModuleCache (FinderCache -> IORef FinderCacheState)
-> FinderCache -> IORef FinderCacheState
forall a b. (a -> b) -> a -> b
$ HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env)
#else
  moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)
#endif
  let go :: (Module, ByteString) -> Maybe (NormalizedFilePath, ByteString)
go (Module
mod, ByteString
hash) = do
        InstalledFindResult
ifr <- FinderCacheState -> InstalledModule -> Maybe InstalledFindResult
forall a. InstalledModuleEnv a -> InstalledModule -> Maybe a
lookupInstalledModuleEnv FinderCacheState
moduleLocs (InstalledModule -> Maybe InstalledFindResult)
-> InstalledModule -> Maybe InstalledFindResult
forall a b. (a -> b) -> a -> b
$ UnitId -> ModuleName -> InstalledModule
forall u. u -> ModuleName -> GenModule u
Compat.installedModule (Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
        case InstalledFindResult
ifr of
          InstalledFound ModLocation
loc InstalledModule
_ -> do
            FilePath
hs <- ModLocation -> Maybe FilePath
ml_hs_file ModLocation
loc
            (NormalizedFilePath, ByteString)
-> Maybe (NormalizedFilePath, ByteString)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
hs,ByteString
hash)
          InstalledFindResult
_ -> Maybe (NormalizedFilePath, ByteString)
forall a. Maybe a
Nothing
      hs_files :: Maybe [(NormalizedFilePath, ByteString)]
hs_files = ((Module, ByteString) -> Maybe (NormalizedFilePath, ByteString))
-> [(Module, ByteString)]
-> Maybe [(NormalizedFilePath, ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Module, ByteString) -> Maybe (NormalizedFilePath, ByteString)
go (ModuleEnv ByteString -> [(Module, ByteString)]
forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ModuleEnv ByteString
runtime_deps)
  case Maybe [(NormalizedFilePath, ByteString)]
hs_files of
    Maybe [(NormalizedFilePath, ByteString)]
Nothing -> FilePath -> m (Maybe RecompileRequired)
forall a. HasCallStack => FilePath -> a
error FilePath
"invalid module graph"
    Just [(NormalizedFilePath, ByteString)]
fs -> do
      [ByteString]
store_hashes <- [NormalizedFilePath] -> m [ByteString]
get_linkable_hashes (((NormalizedFilePath, ByteString) -> NormalizedFilePath)
-> [(NormalizedFilePath, ByteString)] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath, ByteString) -> NormalizedFilePath
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) <- [(NormalizedFilePath, ByteString)]
-> [ByteString] -> [((NormalizedFilePath, ByteString), ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(NormalizedFilePath, ByteString)]
fs [ByteString]
store_hashes, ByteString
expected_hash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
actual_hash]
      case [NormalizedFilePath]
out_of_date of
        [] -> Maybe RecompileRequired -> m (Maybe RecompileRequired)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RecompileRequired
forall a. Maybe a
Nothing
        [NormalizedFilePath]
_ -> Maybe RecompileRequired -> m (Maybe RecompileRequired)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RecompileRequired -> m (Maybe RecompileRequired))
-> Maybe RecompileRequired -> m (Maybe RecompileRequired)
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> Maybe RecompileRequired
forall a. a -> Maybe a
Just (RecompileRequired -> Maybe RecompileRequired)
-> RecompileRequired -> Maybe RecompileRequired
forall a b. (a -> b) -> a -> b
$ FilePath -> RecompileRequired
recompBecause
              (FilePath -> RecompileRequired) -> FilePath -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ FilePath
"out of date runtime dependencies: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((NormalizedFilePath -> FilePath)
-> [NormalizedFilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> FilePath
forall a. Show a => a -> FilePath
show [NormalizedFilePath]
out_of_date)

recompBecause :: String -> RecompileRequired
recompBecause :: FilePath -> RecompileRequired
recompBecause =
#if MIN_VERSION_ghc(9,3,0)
                CompileReason -> RecompileRequired
NeedsRecompile (CompileReason -> RecompileRequired)
-> (FilePath -> CompileReason) -> FilePath -> RecompileRequired
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
#endif
                RecompReason -> CompileReason
RecompBecause
#if MIN_VERSION_ghc(9,3,0)
              (RecompReason -> CompileReason)
-> (FilePath -> RecompReason) -> FilePath -> CompileReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> RecompReason
CustomReason
#endif

#if MIN_VERSION_ghc(9,3,0)
data SourceModified = SourceModified | SourceUnmodified deriving (SourceModified -> SourceModified -> Bool
(SourceModified -> SourceModified -> Bool)
-> (SourceModified -> SourceModified -> Bool) -> Eq SourceModified
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SourceModified -> SourceModified -> Bool
== :: SourceModified -> SourceModified -> Bool
$c/= :: SourceModified -> SourceModified -> Bool
/= :: SourceModified -> SourceModified -> Bool
Eq, Eq SourceModified
Eq SourceModified =>
(SourceModified -> SourceModified -> Ordering)
-> (SourceModified -> SourceModified -> Bool)
-> (SourceModified -> SourceModified -> Bool)
-> (SourceModified -> SourceModified -> Bool)
-> (SourceModified -> SourceModified -> Bool)
-> (SourceModified -> SourceModified -> SourceModified)
-> (SourceModified -> SourceModified -> SourceModified)
-> Ord SourceModified
SourceModified -> SourceModified -> Bool
SourceModified -> SourceModified -> Ordering
SourceModified -> SourceModified -> SourceModified
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SourceModified -> SourceModified -> Ordering
compare :: SourceModified -> SourceModified -> Ordering
$c< :: SourceModified -> SourceModified -> Bool
< :: SourceModified -> SourceModified -> Bool
$c<= :: SourceModified -> SourceModified -> Bool
<= :: SourceModified -> SourceModified -> Bool
$c> :: SourceModified -> SourceModified -> Bool
> :: SourceModified -> SourceModified -> Bool
$c>= :: SourceModified -> SourceModified -> Bool
>= :: SourceModified -> SourceModified -> Bool
$cmax :: SourceModified -> SourceModified -> SourceModified
max :: SourceModified -> SourceModified -> SourceModified
$cmin :: SourceModified -> SourceModified -> SourceModified
min :: SourceModified -> SourceModified -> SourceModified
Ord, Int -> SourceModified -> FilePath -> FilePath
[SourceModified] -> FilePath -> FilePath
SourceModified -> FilePath
(Int -> SourceModified -> FilePath -> FilePath)
-> (SourceModified -> FilePath)
-> ([SourceModified] -> FilePath -> FilePath)
-> Show SourceModified
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> SourceModified -> FilePath -> FilePath
showsPrec :: Int -> SourceModified -> FilePath -> FilePath
$cshow :: SourceModified -> FilePath
show :: SourceModified -> FilePath
$cshowList :: [SourceModified] -> FilePath -> FilePath
showList :: [SourceModified] -> FilePath -> FilePath
Show)
#endif

showReason :: RecompileRequired -> String
showReason :: RecompileRequired -> FilePath
showReason RecompileRequired
UpToDate          = FilePath
"UpToDate"
#if MIN_VERSION_ghc(9,3,0)
showReason (NeedsRecompile CompileReason
MustCompile)    = FilePath
"MustCompile"
showReason (NeedsRecompile CompileReason
s) = CompileReason -> FilePath
forall a. Outputable a => a -> FilePath
printWithoutUniques CompileReason
s
#else
showReason MustCompile       = "MustCompile"
showReason (RecompBecause s) = s
#endif

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

coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts :: HscEnv
-> ModIface_ 'ModIfaceFinal -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts HscEnv
session ModIface_ 'ModIfaceFinal
iface ModDetails
details CoreFile
core_file = do
  let act :: UniqDFM ModuleName HomeModInfo -> UniqDFM ModuleName HomeModInfo
act UniqDFM ModuleName HomeModInfo
hpt = UniqDFM ModuleName HomeModInfo
-> ModuleName -> HomeModInfo -> UniqDFM ModuleName HomeModInfo
addToHpt UniqDFM ModuleName HomeModInfo
hpt (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)
                             (ModIface_ 'ModIfaceFinal
-> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface_ 'ModIfaceFinal
iface ModDetails
details HomeModLinkable
emptyHomeModInfoLinkable)
      this_mod :: Module
this_mod = ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface_ 'ModIfaceFinal
iface
  IORef TypeEnv
types_var <- TypeEnv -> IO (IORef TypeEnv)
forall a. a -> IO (IORef a)
newIORef (ModDetails -> TypeEnv
md_types ModDetails
details)
  let hsc_env' :: HscEnv
hsc_env' = (UniqDFM ModuleName HomeModInfo -> UniqDFM ModuleName HomeModInfo)
-> HscEnv -> HscEnv
hscUpdateHPT UniqDFM ModuleName HomeModInfo -> UniqDFM ModuleName HomeModInfo
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 = Just (this_mod, types_var)
#endif
        })
  CoreProgram
core_binds <- SDoc -> HscEnv -> IfG CoreProgram -> IO CoreProgram
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"l") HscEnv
hsc_env' (IfG CoreProgram -> IO CoreProgram)
-> IfG CoreProgram -> IO CoreProgram
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 = (TyCon -> CoreProgram) -> [TyCon] -> CoreProgram
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
  CgGuts -> IO CgGuts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CgGuts -> IO CgGuts) -> CgGuts -> IO CgGuts
forall a b. (a -> b) -> a -> b
$ Module
-> [TyCon]
-> CoreProgram
-> [CostCentre]
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> Set UnitId
-> HpcInfo
-> Maybe ModBreaks
-> [SptEntry]
-> CgGuts
CgGuts Module
this_mod [TyCon]
tyCons CoreProgram
core_binds [] ForeignStubs
NoStubs [] Set UnitId
forall a. Monoid a => a
mempty (Bool -> HpcInfo
emptyHpcInfo Bool
False) Maybe ModBreaks
forall a. Maybe a
Nothing []
#elif MIN_VERSION_ghc(9,3,0)
  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing []
#else
  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []
#endif

coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)
coreFileToLinkable :: LinkableType
-> HscEnv
-> ModSummary
-> ModIface_ 'ModIfaceFinal
-> ModDetails
-> CoreFile
-> UTCTime
-> IO ([FileDiagnostic], Maybe HomeModInfo)
coreFileToLinkable LinkableType
linkableType HscEnv
session ModSummary
ms ModIface_ 'ModIfaceFinal
iface ModDetails
details CoreFile
core_file UTCTime
t = do
  CgGuts
cgi_guts <- HscEnv
-> ModIface_ 'ModIfaceFinal -> ModDetails -> CoreFile -> IO CgGuts
coreFileToCgGuts HscEnv
session ModIface_ 'ModIfaceFinal
iface ModDetails
details CoreFile
core_file
  ([FileDiagnostic]
warns, HomeModLinkable
lb) <- case LinkableType
linkableType of
    LinkableType
BCOLinkable    -> (Maybe Linkable -> HomeModLinkable)
-> IdeResult Linkable -> ([FileDiagnostic], HomeModLinkable)
forall a b.
(a -> b) -> ([FileDiagnostic], a) -> ([FileDiagnostic], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HomeModLinkable
-> (Linkable -> HomeModLinkable)
-> Maybe Linkable
-> HomeModLinkable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HomeModLinkable
emptyHomeModInfoLinkable Linkable -> HomeModLinkable
justBytecode) (IdeResult Linkable -> ([FileDiagnostic], HomeModLinkable))
-> IO (IdeResult Linkable)
-> IO ([FileDiagnostic], HomeModLinkable)
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 -> (Maybe Linkable -> HomeModLinkable)
-> IdeResult Linkable -> ([FileDiagnostic], HomeModLinkable)
forall a b.
(a -> b) -> ([FileDiagnostic], a) -> ([FileDiagnostic], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HomeModLinkable
-> (Linkable -> HomeModLinkable)
-> Maybe Linkable
-> HomeModLinkable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HomeModLinkable
emptyHomeModInfoLinkable Linkable -> HomeModLinkable
justObjects) (IdeResult Linkable -> ([FileDiagnostic], HomeModLinkable))
-> IO (IdeResult Linkable)
-> IO ([FileDiagnostic], HomeModLinkable)
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
  ([FileDiagnostic], Maybe HomeModInfo)
-> IO ([FileDiagnostic], Maybe HomeModInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
warns, HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just (HomeModInfo -> Maybe HomeModInfo)
-> HomeModInfo -> Maybe HomeModInfo
forall a b. (a -> b) -> a -> b
$ ModIface_ 'ModIfaceFinal
-> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface_ 'ModIfaceFinal
iface ModDetails
details HomeModLinkable
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 FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
getDocsBatch HscEnv
hsc_env [Name]
_names = do
    [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
res <- HscEnv
-> IfG
     [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> IO
     [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG
   [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
 -> IO
      [Either
         GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))])
-> IfG
     [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> IO
     [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
forall a b. (a -> b) -> a -> b
$ [Name]
-> (Name
    -> IOEnv
         (Env IfGblEnv ())
         (Either
            GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))))
-> IfG
     [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
_names ((Name
  -> IOEnv
       (Env IfGblEnv ())
       (Either
          GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))))
 -> IfG
      [Either
         GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))])
-> (Name
    -> IOEnv
         (Env IfGblEnv ())
         (Either
            GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))))
-> IfG
     [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
forall a b. (a -> b) -> a -> b
$ \Name
name ->
        case Name -> Maybe Module
nameModule_maybe Name
name of
            Maybe Module
Nothing -> Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> IOEnv
     (Env IfGblEnv ())
     (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GetDocsFailure
-> Either
     GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. a -> Either a b
Left (GetDocsFailure
 -> Either
      GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-> GetDocsFailure
-> Either
     GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
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 :: forall (phase :: ModIfacePhase). ModIface_ phase -> Maybe Docs
mi_docs = Just Docs{ docs_mod_hdr :: Docs -> Maybe (HsDoc GhcRn)
docs_mod_hdr = Maybe (HsDoc GhcRn)
mb_doc_hdr
                                      , docs_decls :: Docs -> UniqMap Name [HsDoc GhcRn]
docs_decls = UniqMap Name [HsDoc GhcRn]
dmap
                                      , docs_args :: Docs -> UniqMap Name (IntMap (HsDoc GhcRn))
docs_args = UniqMap Name (IntMap (HsDoc GhcRn))
amap
                                      }
#else
                        mi_doc_hdr = mb_doc_hdr
                      , mi_decl_docs = DeclDocMap dmap
                      , mi_arg_docs = ArgDocMap amap
#endif
                      } <- SDoc -> Module -> IfM () (ModIface_ 'ModIfaceFinal)
forall lcl. SDoc -> Module -> IfM lcl (ModIface_ 'ModIfaceFinal)
loadSysInterface (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"getModuleInterface") Module
mod
#if MIN_VERSION_ghc(9,3,0)
             if Maybe (HsDoc GhcRn) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (HsDoc GhcRn)
mb_doc_hdr Bool -> Bool -> Bool
&& UniqMap Name [HsDoc GhcRn] -> Bool
forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap Name [HsDoc GhcRn]
dmap Bool -> Bool -> Bool
&& UniqMap Name (IntMap (HsDoc GhcRn)) -> Bool
forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap Name (IntMap (HsDoc GhcRn))
amap
#else
             if isNothing mb_doc_hdr && Map.null dmap && null amap
#endif
               then Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> IOEnv
     (Env IfGblEnv ())
     (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either
     GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. a -> Either a b
Left (Module -> Bool -> GetDocsFailure
NoDocsInIface Module
mod (Bool -> GetDocsFailure) -> Bool -> GetDocsFailure
forall a b. (a -> b) -> a -> b
$ Name -> Bool
compiled Name
name))
               else Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> IOEnv
     (Env IfGblEnv ())
     (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> Either
     GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. b -> Either a b
Right (
#if MIN_VERSION_ghc(9,3,0)
                                  UniqMap Name [HsDoc GhcRn] -> Name -> Maybe [HsDoc GhcRn]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap Name [HsDoc GhcRn]
dmap Name
name,
#else
                                  Map.lookup name dmap ,
#endif
#if MIN_VERSION_ghc(9,3,0)
                                  UniqMap Name (IntMap (HsDoc GhcRn))
-> IntMap (HsDoc GhcRn) -> Name -> IntMap (HsDoc GhcRn)
forall k a. Uniquable k => UniqMap k a -> a -> k -> a
lookupWithDefaultUniqMap UniqMap Name (IntMap (HsDoc GhcRn))
amap IntMap (HsDoc GhcRn)
forall a. Monoid a => a
mempty Name
name))
#else
                                  Map.findWithDefault mempty name amap))
#endif
    [Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> IO [Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
 -> IO
      [Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))])
-> [Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> IO [Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
forall a b. (a -> b) -> a -> b
$ (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
 -> Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-> [Either
      GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> [Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map ((GetDocsFailure -> FilePath)
-> Either
     GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((GetDocsFailure -> FilePath)
 -> Either
      GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
 -> Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-> (GetDocsFailure -> FilePath)
-> Either
     GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> Either FilePath (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath)
-> (GetDocsFailure -> Text) -> GetDocsFailure -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetDocsFailure -> Text
forall a. Outputable a => a -> Text
printOutputable) [Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
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 = Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TyThing
forall a. Maybe a
Nothing
lookupName HscEnv
hsc_env Name
name = IO (Maybe TyThing) -> IO (Maybe TyThing)
forall {m :: * -> *} {a}.
MonadCatch m =>
m (Maybe a) -> m (Maybe a)
exceptionHandle (IO (Maybe TyThing) -> IO (Maybe TyThing))
-> IO (Maybe TyThing) -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ do
  Maybe TyThing
mb_thing <- IO (Maybe TyThing) -> IO (Maybe TyThing)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> IO (Maybe TyThing))
-> IO (Maybe TyThing) -> IO (Maybe TyThing)
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
_) -> Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
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 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyThing -> Bool
needWiredInHomeIface TyThing
thing)
                 (HscEnv -> IfG () -> IO ()
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (Name -> IfG ()
forall lcl. Name -> IfM lcl ()
loadWiredInHomeIface Name
name))
            Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TyThing
x
      | Bool
otherwise -> do
        MaybeErr SDoc TyThing
res <- HscEnv -> IfG (MaybeErr SDoc TyThing) -> IO (MaybeErr SDoc TyThing)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG (MaybeErr SDoc TyThing) -> IO (MaybeErr SDoc TyThing))
-> IfG (MaybeErr SDoc TyThing) -> IO (MaybeErr SDoc TyThing)
forall a b. (a -> b) -> a -> b
$ Name -> IfG (MaybeErr SDoc TyThing)
forall lcl. Name -> IfM lcl (MaybeErr SDoc TyThing)
importDecl Name
name
        case MaybeErr SDoc TyThing
res of
          Util.Succeeded TyThing
x -> Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just TyThing
x)
          MaybeErr SDoc TyThing
_ -> Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TyThing
forall a. Maybe a
Nothing
  where
    exceptionHandle :: m (Maybe a) -> m (Maybe a)
exceptionHandle m (Maybe a)
x = m (Maybe a)
x m (Maybe a) -> (IOEnvFailure -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOEnvFailure
_ :: IOEnvFailure) -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

pathToModuleName :: FilePath -> ModuleName
pathToModuleName :: FilePath -> ModuleName
pathToModuleName = FilePath -> ModuleName
mkModuleName (FilePath -> ModuleName)
-> (FilePath -> FilePath) -> FilePath -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> FilePath -> FilePath
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)
-}