{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
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
#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
sourceTypecheck :: T.Text
sourceTypecheck :: Text
sourceTypecheck = Text
"typecheck"
sourceParser :: T.Text
sourceParser :: Text
sourceParser = Text
"parser"
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)
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]
}
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)
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
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) }
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
; CoreExpr
simpl_expr <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
simplifyExpr DynFlags
dflags HscEnv
hsc_env CoreExpr
ds_expr
; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr
; CoreExpr
prepd_expr <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr DynFlags
dflags HscEnv
hsc_env CoreExpr
tidy_expr
; 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
#endif
(InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
ModLocation
iNTERACTIVELoc
CoreExpr
prepd_expr
; 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
; 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
#else
moduleName mod
#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)
, Just Module
mod <- [Name -> Maybe Module
nameModule_maybe Name
n]
, 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
]
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
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
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)
; ([(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
; 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)
nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule
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
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
#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
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
-> 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"
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)
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
shareUsages :: ModIface -> ModIface
shareUsages :: ModIface_ 'ModIfaceFinal -> ModIface_ 'ModIfaceFinal
shareUsages ModIface_ 'ModIfaceFinal
iface
= ModIface_ 'ModIfaceFinal
iface
#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') }
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
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')}
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
(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)
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)
#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'
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'
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
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)
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
]
newtype RunSimplifier = RunSimplifier Bool
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
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
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
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)
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
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
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
]
#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
= (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)
requiresTag :: WarningFlag -> Maybe DiagnosticTag
requiresTag WarningFlag
Opt_WarnWarningsDeprecations
= DiagnosticTag -> Maybe DiagnosticTag
forall a. a -> Maybe a
Just DiagnosticTag
DiagnosticTag_Deprecated
#endif
requiresTag WarningFlag
wflag
| 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
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}
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
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 =
#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
]
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 ()
Maybe Fingerprint
_ -> do
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
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
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
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
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
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
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
}
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
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)
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"
}
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
]
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
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
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
getModSummaryFromImports
:: HscEnv
-> FilePath
-> UTCTime
-> Maybe Util.StringBuffer
-> ExceptT [FileDiagnostic] IO ModSummaryResult
getModSummaryFromImports :: HscEnv
-> FilePath
-> UTCTime
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO ModSummaryResult
getModSummaryFromImports HscEnv
env FilePath
fp UTCTime
_modTime Maybe StringBuffer
mContents = do
(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
([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
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
([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
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
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
, 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
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
parseHeader
:: Monad m
=> DynFlags
-> FilePath
-> Util.StringBuffer
#if MIN_VERSION_ghc(9,5,0)
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located (HsModule GhcPs))
#else
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located HsModule)
#endif
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
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)
parseFileContents
:: HscEnv
-> (GHC.ParsedSource -> IdePreprocessedSource)
-> FilePath
-> 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
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
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
[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
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)
}
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"
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)
let _sourceMod :: SourceModified
_sourceMod = case Maybe FileVersion
mb_dest_version of
Maybe FileVersion
Nothing -> SourceModified
SourceModified
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
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
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
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)
(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
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)
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
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 :: 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
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
tyCons :: [TyCon]
tyCons = TypeEnv -> [TyCon]
typeEnvTyCons (ModDetails -> TypeEnv
md_types ModDetails
details)
#if MIN_VERSION_ghc(9,5,0)
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)
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 =
case Name -> SrcLoc
nameSrcLoc Name
n of
RealSrcLoc {} -> Bool
False
UnhelpfulLoc {} -> Bool
True
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