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

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

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

import           Control.Concurrent.Extra
import           Control.Concurrent.STM.Stats      hiding (orElse)
import           Control.DeepSeq                   (force, liftRnf, rnf, rwhnf)
import           Control.Exception                 (evaluate)
import           Control.Exception.Safe
import           Control.Lens                      hiding (List)
import           Control.Monad.Except
import           Control.Monad.Extra
import           Control.Monad.Trans.Except
import           Data.Aeson                        (toJSON)
import           Data.Bifunctor                    (first, second)
import           Data.Binary
import qualified Data.Binary                       as B
import qualified Data.ByteString                   as BS
import qualified Data.ByteString.Lazy              as LBS
import           Data.Coerce
import qualified Data.DList                        as DL
import           Data.Functor
import qualified Data.HashMap.Strict               as HashMap
import           Data.IORef
import           Data.IntMap                       (IntMap)
import qualified Data.IntMap.Strict                as IntMap
import           Data.List.Extra
import           Data.Map                          (Map)
import qualified Data.Map.Strict                   as Map
import           Data.Maybe
import qualified Data.Text                         as T
import           Data.Time                         (UTCTime (..),
                                                    getCurrentTime)
import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)
import           Data.Tuple.Extra                  (dupe)
import           Data.Unique                       as Unique
import           Debug.Trace
import           Development.IDE.Core.Preprocessor
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake
import           Development.IDE.Core.Tracing      (withTrace)
import           Development.IDE.GHC.Compat        hiding (loadInterface,
                                                    parseHeader, parseModule,
                                                    tcRnModule, writeHieFile)
import qualified Development.IDE.GHC.Compat        as Compat
import qualified Development.IDE.GHC.Compat        as GHC
import qualified Development.IDE.GHC.Compat.Util   as Util
import           Development.IDE.GHC.Error
import           Development.IDE.GHC.Orphans       ()
import           Development.IDE.GHC.Util
import           Development.IDE.GHC.Warnings
import           Development.IDE.Spans.Common
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import           GHC                               (ForeignHValue,
                                                    GetDocsFailure (..),
                                                    mgModSummaries,
                                                    parsedSource)
import qualified GHC.LanguageExtensions            as LangExt
import           GHC.Serialized
import           HieDb
import qualified Language.LSP.Server               as LSP
import           Language.LSP.Types                (DiagnosticTag (..))
import qualified Language.LSP.Types                as LSP
import           System.Directory
import           System.FilePath
import           System.IO.Extra                   (fixIO, newTempFileWithin)
import           Unsafe.Coerce

#if !MIN_VERSION_ghc(8,10,0)
import           ErrUtils
#endif

#if MIN_VERSION_ghc(9,0,1)
import           GHC.Tc.Gen.Splice
#else
import           TcSplice
#endif

#if MIN_VERSION_ghc(9,2,0)
import           Development.IDE.GHC.Compat.Util   (emptyUDFM, fsLit,
                                                    plusUDFM_C)
import           GHC                               (Anchor (anchor),
                                                    EpaComment (EpaComment),
                                                    EpaCommentTok (EpaBlockComment, EpaLineComment),
                                                    epAnnComments,
                                                    priorComments)
import qualified GHC                               as G
import           GHC.Hs                            (LEpaComment)
import qualified GHC.Types.Error                   as Error
#endif

-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
parseModule
    :: IdeOptions
    -> HscEnv
    -> FilePath
    -> ModSummary
    -> IO (IdeResult ParsedModule)
parseModule :: IdeOptions
-> HscEnv -> FilePath -> ModSummary -> IO (IdeResult ParsedModule)
parseModule IdeOptions{Bool
Int
FilePath
[FilePath]
[Text]
Maybe FilePath
IO Bool
IO CheckParents
ShakeOptions
Action IdeGhcSession
IdePkgLocationOptions
ProgressReportingStyle
IdeOTMemoryProfiling
IdeTesting
IdeDefer
IdeReportProgress
OptHaddockParse
ParsedSource -> IdePreprocessedSource
Config -> DynFlagsModifications
forall a. Typeable a => a -> Bool
optRunSubset :: IdeOptions -> Bool
optProgressStyle :: IdeOptions -> ProgressReportingStyle
optSkipProgress :: IdeOptions -> forall a. Typeable a => a -> Bool
optShakeOptions :: IdeOptions -> ShakeOptions
optModifyDynFlags :: IdeOptions -> Config -> DynFlagsModifications
optHaddockParse :: IdeOptions -> OptHaddockParse
optCheckParents :: IdeOptions -> IO CheckParents
optCheckProject :: IdeOptions -> IO Bool
optDefer :: IdeOptions -> IdeDefer
optKeywords :: IdeOptions -> [Text]
optNewColonConvention :: IdeOptions -> Bool
optLanguageSyntax :: IdeOptions -> FilePath
optMaxDirtyAge :: IdeOptions -> Int
optReportProgress :: IdeOptions -> IdeReportProgress
optTesting :: IdeOptions -> IdeTesting
optOTMemoryProfiling :: IdeOptions -> IdeOTMemoryProfiling
optShakeProfiling :: IdeOptions -> Maybe FilePath
optExtensions :: IdeOptions -> [FilePath]
optPkgLocationOpts :: IdeOptions -> IdePkgLocationOptions
optGhcSession :: IdeOptions -> Action IdeGhcSession
optPreprocessor :: IdeOptions -> ParsedSource -> IdePreprocessedSource
optRunSubset :: Bool
optProgressStyle :: ProgressReportingStyle
optSkipProgress :: forall a. Typeable a => a -> Bool
optShakeOptions :: ShakeOptions
optModifyDynFlags :: Config -> DynFlagsModifications
optHaddockParse :: OptHaddockParse
optCheckParents :: IO CheckParents
optCheckProject :: IO Bool
optDefer :: IdeDefer
optKeywords :: [Text]
optNewColonConvention :: Bool
optLanguageSyntax :: FilePath
optMaxDirtyAge :: Int
optReportProgress :: IdeReportProgress
optTesting :: IdeTesting
optOTMemoryProfiling :: IdeOTMemoryProfiling
optShakeProfiling :: Maybe FilePath
optExtensions :: [FilePath]
optPkgLocationOpts :: IdePkgLocationOptions
optGhcSession :: Action IdeGhcSession
optPreprocessor :: ParsedSource -> IdePreprocessedSource
..} HscEnv
env FilePath
filename ModSummary
ms =
    (Either [FileDiagnostic] (IdeResult ParsedModule)
 -> IdeResult ParsedModule)
-> IO (Either [FileDiagnostic] (IdeResult ParsedModule))
-> IO (IdeResult ParsedModule)
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 (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
diag, ParsedModule -> Maybe ParsedModule
forall a. a -> Maybe a
Just ParsedModule
modu)


-- | Given a package identifier, what packages does it depend on
computePackageDeps
    :: HscEnv
    -> Unit
    -> IO (Either [FileDiagnostic] [UnitId])
computePackageDeps :: HscEnv -> Unit -> IO (Either [FileDiagnostic] [Unit])
computePackageDeps HscEnv
env Unit
pkg = do
    case HscEnv -> Unit -> Maybe UnitInfo
lookupUnit HscEnv
env Unit
pkg of
        Maybe UnitInfo
Nothing -> Either [FileDiagnostic] [Unit]
-> IO (Either [FileDiagnostic] [Unit])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] [Unit]
 -> IO (Either [FileDiagnostic] [Unit]))
-> Either [FileDiagnostic] [Unit]
-> IO (Either [FileDiagnostic] [Unit])
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Either [FileDiagnostic] [Unit]
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] [Unit]
-> IO (Either [FileDiagnostic] [Unit])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] [Unit]
 -> IO (Either [FileDiagnostic] [Unit]))
-> Either [FileDiagnostic] [Unit]
-> IO (Either [FileDiagnostic] [Unit])
forall a b. (a -> b) -> a -> b
$ [Unit] -> Either [FileDiagnostic] [Unit]
forall a b. b -> Either a b
Right ([Unit] -> Either [FileDiagnostic] [Unit])
-> [Unit] -> Either [FileDiagnostic] [Unit]
forall a b. (a -> b) -> a -> b
$ UnitInfo -> [Unit]
unitDepends UnitInfo
pkgInfo

typecheckModule :: IdeDefer
                -> HscEnv
                -> ModuleEnv UTCTime -- ^ linkables not to unload
                -> ParsedModule
                -> IO (IdeResult TcModuleResult)
typecheckModule :: IdeDefer
-> HscEnv
-> ModuleEnv UTCTime
-> ParsedModule
-> IO (IdeResult TcModuleResult)
typecheckModule (IdeDefer Bool
defer) HscEnv
hsc ModuleEnv UTCTime
keep_lbls 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
mmodSummary' <- DynFlags
-> Text -> IO ModSummary -> IO (Either [FileDiagnostic] ModSummary)
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
initPlugins HscEnv
hsc ModSummary
modSummary)
        case Either [FileDiagnostic] ModSummary
mmodSummary' of
          Left [FileDiagnostic]
errs -> IdeResult TcModuleResult -> IO (IdeResult TcModuleResult)
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
errs, Maybe TcModuleResult
forall a. Maybe a
Nothing)
          Right ModSummary
modSummary' -> do
            ([(WarnReason, FileDiagnostic)]
warnings, Either [FileDiagnostic] TcModuleResult
etcm) <- Text
-> ((HscEnv -> HscEnv)
    -> IO (Either [FileDiagnostic] TcModuleResult))
-> IO
     ([(WarnReason, FileDiagnostic)],
      Either [FileDiagnostic] TcModuleResult)
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"typecheck" (((HscEnv -> HscEnv)
  -> IO (Either [FileDiagnostic] TcModuleResult))
 -> IO
      ([(WarnReason, FileDiagnostic)],
       Either [FileDiagnostic] TcModuleResult))
-> ((HscEnv -> HscEnv)
    -> IO (Either [FileDiagnostic] TcModuleResult))
-> IO
     ([(WarnReason, 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
hsc)
                   -- TODO: maybe settings ms_hspp_opts is unnecessary?
                  mod_summary'' :: ModSummary
mod_summary'' = ModSummary
modSummary' { ms_hspp_opts :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
session}
                in
                  DynFlags
-> Text
-> IO TcModuleResult
-> IO (Either [FileDiagnostic] TcModuleResult)
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc) Text
"typecheck" (IO TcModuleResult -> IO (Either [FileDiagnostic] TcModuleResult))
-> IO TcModuleResult -> IO (Either [FileDiagnostic] TcModuleResult)
forall a b. (a -> b) -> a -> b
$ do
                    HscEnv -> ModuleEnv UTCTime -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
session ModuleEnv UTCTime
keep_lbls (ParsedModule -> IO TcModuleResult)
-> ParsedModule -> IO TcModuleResult
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedModule
demoteIfDefer ParsedModule
pm{pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
mod_summary''}
            let errorPipeline :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
errorPipeline = (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer ((WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic))
-> ((WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic))
-> (WarnReason, FileDiagnostic)
-> (Bool, FileDiagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
hideDiag DynFlags
dflags ((WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic))
-> ((WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic))
-> (WarnReason, FileDiagnostic)
-> (WarnReason, FileDiagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
tagDiag
                diags :: [(Bool, FileDiagnostic)]
diags = ((WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic))
-> [(WarnReason, FileDiagnostic)] -> [(Bool, FileDiagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
errorPipeline [(WarnReason, FileDiagnostic)]
warnings
                deferedError :: Bool
deferedError = ((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 (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 (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{tmrDeferedError :: Bool
tmrDeferedError = Bool
deferedError})
    where
        demoteIfDefer :: ParsedModule -> ParsedModule
demoteIfDefer = if Bool
defer then ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings else ParsedModule -> ParsedModule
forall a. a -> a
id

-- | Install hooks to capture the splices as well as the runtime module dependencies
captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)
captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)
captureSplicesAndDeps 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 (UniqSet ModuleName)
dep_ref <- UniqSet ModuleName -> IO (IORef (UniqSet ModuleName))
forall a. a -> IO (IORef a)
newIORef UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet
  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 (UniqSet ModuleName) -> Hooks -> Hooks
addLinkableDepHook IORef (UniqSet ModuleName)
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
  UniqSet ModuleName
needed_mods <- IORef (UniqSet ModuleName) -> IO (UniqSet ModuleName)
forall a. IORef a -> IO a
readIORef IORef (UniqSet ModuleName)
dep_ref
  (a, Splices, UniqSet ModuleName)
-> IO (a, Splices, UniqSet ModuleName)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Splices
splices, UniqSet ModuleName
needed_mods)
  where
    addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks
    addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks
addLinkableDepHook IORef (UniqSet ModuleName)
var Hooks
h = Hooks
h { hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook = (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
-> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
forall a. a -> Maybe a
Just (IORef (UniqSet ModuleName)
-> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
compile_bco_hook IORef (UniqSet ModuleName)
var) }

    -- We want to record exactly which linkables/modules the typechecker needed at runtime
    -- This is useful for recompilation checking.
    -- See Note [Recompilation avoidance in the presence of TH]
    --
    -- From hscCompileCoreExpr' in GHC
    -- To update, copy hscCompileCoreExpr' (the implementation of
    -- hscCompileCoreExprHook) verbatim, and add code to extract all the free
    -- names in the compiled bytecode, recording the modules that those names
    -- come from in the IORef,, as these are the modules on whose implementation
    -- we depend.
    --
    -- Only compute direct dependencies instead of transitive dependencies.
    -- It is much cheaper to store the direct dependencies, we can compute
    -- the transitive ones when required.
    -- Also only record dependencies from the home package
    compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
    compile_bco_hook :: IORef (UniqSet ModuleName)
-> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
compile_bco_hook IORef (UniqSet ModuleName)
var HscEnv
hsc_env SrcSpan
srcspan CoreExpr
ds_expr
      = do { let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

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

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

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

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


#if MIN_VERSION_ghc(9,2,0)
           ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file   = Nothing,
                                        ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",
                                        ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",
                                        ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }
           ; let ictxt = hsc_IC hsc_env

           ; (binding_id, stg_expr, _, _) <-
               myCoreToStgExpr (hsc_logger hsc_env)
                               (hsc_dflags hsc_env)
                               ictxt
                               (icInteractiveModule ictxt)
                               iNTERACTIVELoc
                               prepd_expr

             {- Convert to BCOs -}
           ; bcos <- byteCodeGen hsc_env
                       (icInteractiveModule ictxt)
                       stg_expr
                       [] Nothing
           ; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos
                                         , Just mod <- [nameModule_maybe n] -- Names from other modules
                                         , not (isWiredInName n) -- Exclude wired-in names
                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package
                                         ]
            -- Exclude wired-in names because we may not have read
            -- their interface files, so getLinkDeps will fail
            -- All wired-in names are in the base package, which we link
            -- by default, so we can safely ignore them here.

             {- load it -}
           ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)
#else
             {- Convert to BCOs -}
           ; UnlinkedBCO
bcos <- HscEnv -> Module -> CoreExpr -> IO UnlinkedBCO
coreExprToBCOs HscEnv
hsc_env
                       (InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)) CoreExpr
prepd_expr

           ; let needed_mods :: UniqSet ModuleName
needed_mods = [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [ Module -> ModuleName
moduleName Module
mod | Name
n <- UniqDSet Name -> [Name]
forall a. UniqDSet a -> [a]
uniqDSetToList (UnlinkedBCO -> UniqDSet Name
bcoFreeNames UnlinkedBCO
bcos)
                                         , Just Module
mod <- [Name -> Maybe Module
nameModule_maybe Name
n] -- Names from other modules
                                         , Bool -> Bool
not (Name -> Bool
isWiredInName Name
n) -- Exclude wired-in names
                                         , Module -> Unit
moduleUnitId Module
mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Unit
homeUnitId_ DynFlags
dflags -- Only care about stuff from the home package
                                         ]
            -- Exclude wired-in names because we may not have read
            -- their interface files, so getLinkDeps will fail
            -- All wired-in names are in the base package, which we link
            -- by default, so we can safely ignore them here.

             {- link it -}
           ; ForeignHValue
hval <- HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
linkExpr HscEnv
hsc_env SrcSpan
srcspan UnlinkedBCO
bcos
#endif

           ; IORef (UniqSet ModuleName)
-> (UniqSet ModuleName -> UniqSet ModuleName) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (UniqSet ModuleName)
var (UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet ModuleName
needed_mods)
           ; ForeignHValue -> IO ForeignHValue
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignHValue
hval }


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

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


tcRnModule
  :: HscEnv
  -> ModuleEnv UTCTime -- ^ Program linkables not to unload
  -> ParsedModule
  -> IO TcModuleResult
tcRnModule :: HscEnv -> ModuleEnv UTCTime -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
hsc_env ModuleEnv UTCTime
keep_lbls 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
      hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env

  HscEnv -> [Linkable] -> IO ()
unload HscEnv
hsc_env_tmp ([Linkable] -> IO ()) -> [Linkable] -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Module, UTCTime) -> Linkable)
-> [(Module, UTCTime)] -> [Linkable]
forall a b. (a -> b) -> [a] -> [b]
map (\(Module
mod, UTCTime
time) -> UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
time Module
mod []) ([(Module, UTCTime)] -> [Linkable])
-> [(Module, UTCTime)] -> [Linkable]
forall a b. (a -> b) -> a -> b
$ ModuleEnv UTCTime -> [(Module, UTCTime)]
forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ModuleEnv UTCTime
keep_lbls

  ((TcGblEnv
tc_gbl_env', RenamedStuff
mrn_info), Splices
splices, UniqSet ModuleName
mods)
      <- HscEnv
-> (HscEnv -> IO (TcGblEnv, RenamedStuff))
-> IO ((TcGblEnv, RenamedStuff), Splices, UniqSet ModuleName)
forall a.
HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)
captureSplicesAndDeps HscEnv
hsc_env_tmp ((HscEnv -> IO (TcGblEnv, RenamedStuff))
 -> IO ((TcGblEnv, RenamedStuff), Splices, UniqSet ModuleName))
-> (HscEnv -> IO (TcGblEnv, RenamedStuff))
-> IO ((TcGblEnv, RenamedStuff), Splices, UniqSet ModuleName)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env_tmp ->
             do  HscEnv
-> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename HscEnv
hsc_env_tmp ModSummary
ms (HsParsedModule -> IO (TcGblEnv, RenamedStuff))
-> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
forall a b. (a -> b) -> a -> b
$
                          HsParsedModule :: ParsedSource -> [FilePath] -> ApiAnns -> HsParsedModule
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 :: ApiAnns
hpm_annotations = ParsedModule -> ApiAnns
pm_annotations ParsedModule
pmod }
  let rn_info :: (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
 Maybe LHsDocString)
rn_info = case RenamedStuff
mrn_info of
        Just (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
 Maybe LHsDocString)
x  -> (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
 Maybe LHsDocString)
x
        RenamedStuff
Nothing -> FilePath
-> (HsGroup GhcRn, [LImportDecl GhcRn],
    Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString)
forall a. HasCallStack => FilePath -> a
error FilePath
"no renamed info tcRnModule"

      -- Compute the transitive set of linkables required
      mods_transitive :: UniqSet ModuleName
mods_transitive = UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
go UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet UniqSet ModuleName
mods
        where
          go :: UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
go UniqSet ModuleName
seen UniqSet ModuleName
new
            | UniqSet ModuleName -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet ModuleName
new = UniqSet ModuleName
seen
            | Bool
otherwise = UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
go UniqSet ModuleName
seen' UniqSet ModuleName
new'
              where
                seen' :: UniqSet ModuleName
seen' = UniqSet ModuleName
seen UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` UniqSet ModuleName
new
                new' :: UniqSet ModuleName
new'  = UniqSet ModuleName
new_deps UniqSet ModuleName -> UniqSet ModuleName -> UniqSet ModuleName
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet ModuleName
seen'
                new_deps :: UniqSet ModuleName
new_deps = [UniqSet ModuleName] -> UniqSet ModuleName
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets [ [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([ModuleName] -> UniqSet ModuleName)
-> [ModuleName] -> UniqSet ModuleName
forall a b. (a -> b) -> a -> b
$ ModIface -> [ModuleName]
getDependentMods (ModIface -> [ModuleName]) -> ModIface -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info
                                             | HomeModInfo
mod_info <- HomePackageTable -> [HomeModInfo]
forall elt. UniqDFM elt -> [elt]
eltsUDFM (HomePackageTable -> [HomeModInfo])
-> HomePackageTable -> [HomeModInfo]
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> UniqFM ModuleName -> HomePackageTable
forall elt1 elt2. UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1
udfmIntersectUFM HomePackageTable
hpt (UniqSet ModuleName -> UniqFM ModuleName
forall a. UniqSet a -> UniqFM a
getUniqSet UniqSet ModuleName
new)]

      -- The linkables we depend on at runtime are the transitive closure of 'mods'
      -- restricted to the home package
      -- See Note [Recompilation avoidance in the presence of TH]
      mod_env :: ModuleEnv UTCTime
mod_env = (Module -> UTCTime -> Bool)
-> ModuleEnv UTCTime -> ModuleEnv UTCTime
forall a. (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
filterModuleEnv (\Module
m UTCTime
_ -> ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet (Module -> ModuleName
moduleName Module
m) UniqSet ModuleName
mods_transitive) ModuleEnv UTCTime
keep_lbls -- Could use restrictKeys if the constructors were exported

      -- Serialize mod_env so we can read it from the interface
      mod_env_anns :: [Annotation]
mod_env_anns = ((Module, UTCTime) -> Annotation)
-> [(Module, UTCTime)] -> [Annotation]
forall a b. (a -> b) -> [a] -> [b]
map (\(Module
mod, UTCTime
time) -> 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
$ (ModDepTime -> [Word8]) -> ModDepTime -> Serialized
forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized ModDepTime -> [Word8]
serializeModDepTime (UTCTime -> ModDepTime
ModDepTime UTCTime
time))
                         (ModuleEnv UTCTime -> [(Module, UTCTime)]
forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ModuleEnv UTCTime
mod_env)
      tc_gbl_env :: TcGblEnv
tc_gbl_env = TcGblEnv
tc_gbl_env' { tcg_ann_env :: AnnEnv
tcg_ann_env = AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
tc_gbl_env') [Annotation]
mod_env_anns }
  TcModuleResult -> IO TcModuleResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedModule
-> (HsGroup GhcRn, [LImportDecl GhcRn],
    Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString)
-> TcGblEnv
-> Splices
-> Bool
-> ModuleEnv UTCTime
-> TcModuleResult
TcModuleResult ParsedModule
pmod (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
 Maybe LHsDocString)
rn_info TcGblEnv
tc_gbl_env Splices
splices Bool
False ModuleEnv UTCTime
mod_env)

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
#if MIN_VERSION_ghc(8,10,0)
  ModIface
iface <- HscEnv -> SafeHaskellMode -> ModDetails -> TcGblEnv -> IO ModIface
mkIfaceTc HscEnv
hsc_env_tmp SafeHaskellMode
sf ModDetails
details TcGblEnv
tcGblEnv
#else
  (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv
#endif
  let mod_info :: HomeModInfo
mod_info = ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details Maybe Linkable
forall a. Maybe a
Nothing
  HiFileResult -> IO HiFileResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HiFileResult -> IO HiFileResult)
-> HiFileResult -> IO HiFileResult
forall a b. (a -> b) -> a -> b
$! ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult
mkHiFileResult ModSummary
ms HomeModInfo
mod_info (TcModuleResult -> ModuleEnv UTCTime
tmrRuntimeModules TcModuleResult
tcm)

mkHiFileResultCompile
    :: HscEnv
    -> TcModuleResult
    -> ModGuts
    -> LinkableType -- ^ use object code or byte code?
    -> IO (IdeResult HiFileResult)
mkHiFileResultCompile :: HscEnv
-> TcModuleResult
-> ModGuts
-> LinkableType
-> IO (IdeResult HiFileResult)
mkHiFileResultCompile HscEnv
session' TcModuleResult
tcm ModGuts
simplified_guts LinkableType
ltype = 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
      tcGblEnv :: TcGblEnv
tcGblEnv = TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tcm

  let genLinkable :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
genLinkable = case LinkableType
ltype of
        LinkableType
ObjectLinkable -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode
        LinkableType
BCOLinkable    -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode

  (Maybe Linkable
linkable, ModDetails
details, [FileDiagnostic]
diags) <-
    if ModGuts -> HscSource
mg_hsc_src ModGuts
simplified_guts HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
    then do
        -- give variables unique OccNames
        ModDetails
details <- HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
session TcGblEnv
tcGblEnv
        (Maybe Linkable, ModDetails, [FileDiagnostic])
-> IO (Maybe Linkable, ModDetails, [FileDiagnostic])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Linkable
forall a. Maybe a
Nothing, ModDetails
details, [])
    else do
        -- give variables unique OccNames
        (CgGuts
guts, ModDetails
details) <- HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
session ModGuts
simplified_guts
        ([FileDiagnostic]
diags, Maybe Linkable
linkable) <- HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
genLinkable HscEnv
session ModSummary
ms CgGuts
guts
        (Maybe Linkable, ModDetails, [FileDiagnostic])
-> IO (Maybe Linkable, ModDetails, [FileDiagnostic])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Linkable
linkable, ModDetails
details, [FileDiagnostic]
diags)
#if MIN_VERSION_ghc(9,0,1)
  let !partial_iface = force (mkPartialIface session details simplified_guts)
  final_iface <- mkFullIface session partial_iface Nothing
#elif MIN_VERSION_ghc(8,10,0)
  let !partial_iface :: PartialModIface
partial_iface = PartialModIface -> PartialModIface
forall a. NFData a => a -> a
force (HscEnv -> ModDetails -> ModGuts -> PartialModIface
mkPartialIface HscEnv
session ModDetails
details ModGuts
simplified_guts)
  ModIface
final_iface <- HscEnv -> PartialModIface -> IO ModIface
mkFullIface HscEnv
session PartialModIface
partial_iface
#else
  (final_iface,_) <- mkIface session Nothing details simplified_guts
#endif
  let mod_info :: HomeModInfo
mod_info = ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
final_iface ModDetails
details Maybe Linkable
linkable
  IdeResult HiFileResult -> IO (IdeResult HiFileResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diags, HiFileResult -> Maybe HiFileResult
forall a. a -> Maybe a
Just (HiFileResult -> Maybe HiFileResult)
-> HiFileResult -> Maybe HiFileResult
forall a b. (a -> b) -> a -> b
$! ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult
mkHiFileResult ModSummary
ms HomeModInfo
mod_info (TcModuleResult -> ModuleEnv UTCTime
tmrRuntimeModules TcModuleResult
tcm))

  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.
(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 (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 (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
DsError (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 -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (SomeException -> FilePath) -> SomeException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Show SomeException => SomeException -> FilePath
forall a. Show a => a -> FilePath
show @SomeException
      ]

initPlugins :: HscEnv -> ModSummary -> IO ModSummary
initPlugins :: HscEnv -> ModSummary -> IO ModSummary
initPlugins HscEnv
session ModSummary
modSummary = do
    HscEnv
session1 <- IO HscEnv -> IO HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> IO HscEnv) -> IO HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
initializePlugins (DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSummary) HscEnv
session)
    ModSummary -> IO ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
modSummary{ms_hspp_opts :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
session1}

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

-- | Compile a single type-checked module to a 'CoreModule' value, or
-- provide errors.
compileModule
    :: RunSimplifier
    -> HscEnv
    -> ModSummary
    -> TcGblEnv
    -> IO (IdeResult ModGuts)
compileModule :: RunSimplifier
-> HscEnv -> ModSummary -> TcGblEnv -> IO (IdeResult ModGuts)
compileModule (RunSimplifier Bool
simplify) HscEnv
session ModSummary
ms TcGblEnv
tcg =
    (Either [FileDiagnostic] ([FileDiagnostic], ModGuts)
 -> IdeResult ModGuts)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], ModGuts))
-> IO (IdeResult ModGuts)
forall (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 (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
            ([(WarnReason, FileDiagnostic)]
warnings,ModGuts
desugared_guts) <- Text
-> ((HscEnv -> HscEnv) -> IO ModGuts)
-> IO ([(WarnReason, FileDiagnostic)], ModGuts)
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"compile" (((HscEnv -> HscEnv) -> IO ModGuts)
 -> IO ([(WarnReason, FileDiagnostic)], ModGuts))
-> ((HscEnv -> HscEnv) -> IO ModGuts)
-> IO ([(WarnReason, FileDiagnostic)], ModGuts)
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
ms) HscEnv
session)
               -- TODO: maybe settings ms_hspp_opts is unnecessary?
               -- MP: the flags in ModSummary should be right, if they are wrong then
               -- the correct place to fix this is when the ModSummary is created.
               ModGuts
desugar <- HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
session' (ModSummary
ms { ms_hspp_opts :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
session' })  TcGblEnv
tcg
               if Bool
simplify
               then do
                 [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 (f :: * -> *) a. Applicative f => a -> f a
pure ModGuts
desugar
            ([FileDiagnostic], ModGuts) -> IO ([FileDiagnostic], ModGuts)
forall (m :: * -> *) a. Monad m => a -> m a
return (((WarnReason, FileDiagnostic) -> FileDiagnostic)
-> [(WarnReason, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (WarnReason, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(WarnReason, FileDiagnostic)]
warnings, ModGuts
desugared_guts)

generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode HscEnv
session ModSummary
summary CgGuts
guts = do
    (Either [FileDiagnostic] ([FileDiagnostic], Linkable)
 -> IdeResult Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
-> IO (IdeResult Linkable)
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 (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)
              ([(WarnReason, FileDiagnostic)]
warnings, FilePath
dot_o_fp) <-
                Text
-> ((HscEnv -> HscEnv) -> IO FilePath)
-> IO ([(WarnReason, FileDiagnostic)], FilePath)
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"object" (((HscEnv -> HscEnv) -> IO FilePath)
 -> IO ([(WarnReason, FileDiagnostic)], FilePath))
-> ((HscEnv -> HscEnv) -> IO FilePath)
-> IO ([(WarnReason, 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
$ FilePath -> DynFlags -> DynFlags
setOutputFile FilePath
dot_o (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,0,1)
                      (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts
#else
                      (FilePath
outputFilename, Maybe FilePath
_mStub, [(ForeignSrcLang, FilePath)]
_foreign_files) <- HscEnv
-> CgGuts
-> ModLocation
-> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
hscGenHardCode HscEnv
session' CgGuts
guts
#endif
#if MIN_VERSION_ghc(8,10,0)
                                (ModSummary -> ModLocation
ms_location ModSummary
summary)
#else
                                summary
#endif
                                FilePath
fp
                      HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile HscEnv
session' Phase
StopLn (FilePath
outputFilename, Phase -> Maybe Phase
forall a. a -> Maybe a
Just (Bool -> Phase
As Bool
False))
              let unlinked :: Unlinked
unlinked = FilePath -> Unlinked
DotO FilePath
dot_o_fp
              -- Need time to be the modification time for recompilation checking
              UTCTime
t <- IO UTCTime -> IO UTCTime
forall (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 (f :: * -> *) a. Applicative f => a -> f a
pure (((WarnReason, FileDiagnostic) -> FileDiagnostic)
-> [(WarnReason, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (WarnReason, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(WarnReason, FileDiagnostic)]
warnings, Linkable
linkable)

generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode HscEnv
hscEnv ModSummary
summary CgGuts
guts = do
    (Either [FileDiagnostic] ([FileDiagnostic], Linkable)
 -> IdeResult Linkable)
-> IO (Either [FileDiagnostic] ([FileDiagnostic], Linkable))
-> IO (IdeResult Linkable)
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 (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
              ([(WarnReason, FileDiagnostic)]
warnings, (Maybe FilePath
_, CompiledByteCode
bytecode, [SptEntry]
sptEntries)) <-
                Text
-> ((HscEnv -> HscEnv)
    -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
-> IO
     ([(WarnReason, FileDiagnostic)],
      (Maybe FilePath, CompiledByteCode, [SptEntry]))
forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"bytecode" (((HscEnv -> HscEnv)
  -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
 -> IO
      ([(WarnReason, FileDiagnostic)],
       (Maybe FilePath, CompiledByteCode, [SptEntry])))
-> ((HscEnv -> HscEnv)
    -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
-> IO
     ([(WarnReason, FileDiagnostic)],
      (Maybe FilePath, CompiledByteCode, [SptEntry]))
forall a b. (a -> b) -> a -> b
$ \HscEnv -> HscEnv
_tweak -> do
                      let session :: HscEnv
session = HscEnv -> HscEnv
_tweak (DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary) HscEnv
hscEnv)
                          -- TODO: maybe settings ms_hspp_opts is unnecessary?
                          summary' :: ModSummary
summary' = ModSummary
summary { ms_hspp_opts :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
session }
                      HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
session CgGuts
guts
#if MIN_VERSION_ghc(8,10,0)
                                (ModSummary -> ModLocation
ms_location ModSummary
summary')
#else
                                summary'
#endif
              let unlinked :: Unlinked
unlinked = CompiledByteCode -> [SptEntry] -> Unlinked
BCOs CompiledByteCode
bytecode [SptEntry]
sptEntries
              UTCTime
time <- IO UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              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 (f :: * -> *) a. Applicative f => a -> f a
pure (((WarnReason, FileDiagnostic) -> FileDiagnostic)
-> [(WarnReason, FileDiagnostic)] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (WarnReason, FileDiagnostic) -> FileDiagnostic
forall a b. (a, b) -> b
snd [(WarnReason, FileDiagnostic)]
warnings, Linkable
linkable)

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

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

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

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

unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer (Reason WarningFlag
Opt_WarnDeferredTypeErrors         , FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
unDefer (Reason WarningFlag
Opt_WarnTypedHoles                 , FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
unDefer (Reason WarningFlag
Opt_WarnDeferredOutOfScopeVariables, FileDiagnostic
fd) = (Bool
True, FileDiagnostic -> FileDiagnostic
upgradeWarningToError FileDiagnostic
fd)
unDefer ( WarnReason
_                                        , FileDiagnostic
fd) = (Bool
False, FileDiagnostic
fd)

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

hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
hideDiag :: DynFlags
-> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
hideDiag DynFlags
originalFlags (Reason WarningFlag
warning, (NormalizedFilePath
nfp, ShowDiagnostic
_sh, Diagnostic
fd))
  | Bool -> Bool
not (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
warning DynFlags
originalFlags)
  = (WarningFlag -> WarnReason
Reason WarningFlag
warning, (NormalizedFilePath
nfp, ShowDiagnostic
HideDiag, Diagnostic
fd))
hideDiag DynFlags
_originalFlags (WarnReason, FileDiagnostic)
t = (WarnReason, FileDiagnostic)
t

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

-- | Add a unnecessary/deprecated tag to the required diagnostics.
tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
tagDiag (Reason WarningFlag
warning, (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd))
  | Just DiagnosticTag
tag <- WarningFlag -> Maybe DiagnosticTag
requiresTag WarningFlag
warning
  = (WarningFlag -> WarnReason
Reason WarningFlag
warning, (NormalizedFilePath
nfp, ShowDiagnostic
sh, Diagnostic
fd { $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags = DiagnosticTag
-> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag)
addTag DiagnosticTag
tag (Diagnostic -> Maybe (List DiagnosticTag)
_tags Diagnostic
fd) }))
  where
    requiresTag :: WarningFlag -> Maybe DiagnosticTag
    requiresTag :: WarningFlag -> Maybe DiagnosticTag
requiresTag WarningFlag
Opt_WarnWarningsDeprecations
      = DiagnosticTag -> Maybe DiagnosticTag
forall a. a -> Maybe a
Just DiagnosticTag
DtDeprecated
    requiresTag WarningFlag
wflag  -- deprecation was already considered above
      | WarningFlag
wflag WarningFlag -> [WarningFlag] -> 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
DtUnnecessary
    requiresTag WarningFlag
_ = Maybe DiagnosticTag
forall a. Maybe a
Nothing
    addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag)
    addTag :: DiagnosticTag
-> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag)
addTag DiagnosticTag
t Maybe (List DiagnosticTag)
Nothing          = List DiagnosticTag -> Maybe (List DiagnosticTag)
forall a. a -> Maybe a
Just ([DiagnosticTag] -> List DiagnosticTag
forall a. [a] -> List a
List [DiagnosticTag
t])
    addTag DiagnosticTag
t (Just (List [DiagnosticTag]
ts)) = List DiagnosticTag -> Maybe (List DiagnosticTag)
forall a. a -> Maybe a
Just ([DiagnosticTag] -> List DiagnosticTag
forall a. [a] -> List a
List (DiagnosticTag
t DiagnosticTag -> [DiagnosticTag] -> [DiagnosticTag]
forall a. a -> [a] -> [a]
: [DiagnosticTag]
ts))
-- other diagnostics are left unaffected
tagDiag (WarnReason, FileDiagnostic)
t = (WarnReason, FileDiagnostic)
t

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

atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
atomicFileWrite 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 -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> FilePath -> IO ()
renameFile FilePath
tempFilePath FilePath
targetPath) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`onException` IO ()
cleanUp

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

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

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

    -- Get a progress token to report progress and update it for the current file
    pre :: ProgressReportingStyle -> IO ()
pre ProgressReportingStyle
style = do
      Maybe ProgressToken
tok <- 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ProgressToken
x
        -- Create a token if we don't already have one
        Maybe ProgressToken
Nothing -> do
          case ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se of
            Maybe (LanguageContextEnv Config)
Nothing -> Maybe ProgressToken -> IO (Maybe ProgressToken)
forall (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 <- Text -> ProgressToken
LSP.ProgressTextToken (Text -> ProgressToken)
-> (Unique -> Text) -> Unique -> ProgressToken
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
Unique.newUnique
              -- TODO: Wait for the progress create response to use the token
              LspId 'WindowWorkDoneProgressCreate
_ <- SServerMethod 'WindowWorkDoneProgressCreate
-> MessageParams 'WindowWorkDoneProgressCreate
-> (Either
      ResponseError (ResponseResult 'WindowWorkDoneProgressCreate)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WindowWorkDoneProgressCreate)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WindowWorkDoneProgressCreate
LSP.SWindowWorkDoneProgressCreate (ProgressToken -> WorkDoneProgressCreateParams
LSP.WorkDoneProgressCreateParams ProgressToken
u) (LspT Config IO ()
-> Either ResponseError Empty -> LspT Config IO ()
forall a b. a -> b -> a
const (LspT Config IO ()
 -> Either ResponseError Empty -> LspT Config IO ())
-> LspT Config IO ()
-> Either ResponseError Empty
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              SServerMethod 'Progress
-> MessageParams 'Progress -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Progress
LSP.SProgress (MessageParams 'Progress -> LspT Config IO ())
-> MessageParams 'Progress -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken
-> SomeProgressParams -> ProgressParams SomeProgressParams
forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams ProgressToken
u (SomeProgressParams -> ProgressParams SomeProgressParams)
-> SomeProgressParams -> ProgressParams SomeProgressParams
forall a b. (a -> b) -> a -> b
$
                WorkDoneProgressBeginParams -> SomeProgressParams
LSP.Begin (WorkDoneProgressBeginParams -> SomeProgressParams)
-> WorkDoneProgressBeginParams -> SomeProgressParams
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressBeginParams :: Text
-> Maybe Bool
-> Maybe Text
-> Maybe UInt
-> WorkDoneProgressBeginParams
LSP.WorkDoneProgressBeginParams
                  { $sel:_title:WorkDoneProgressBeginParams :: Text
_title = Text
"Indexing"
                  , $sel:_cancellable:WorkDoneProgressBeginParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                  , $sel:_message:WorkDoneProgressBeginParams :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                  , $sel:_percentage:WorkDoneProgressBeginParams :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                  }
              Maybe ProgressToken -> LspT Config IO (Maybe ProgressToken)
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 (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 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
tok -> 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 'Progress
-> MessageParams 'Progress -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Progress
LSP.SProgress (MessageParams 'Progress -> LspT Config IO ())
-> MessageParams 'Progress -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken
-> SomeProgressParams -> ProgressParams SomeProgressParams
forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams ProgressToken
tok (SomeProgressParams -> ProgressParams SomeProgressParams)
-> SomeProgressParams -> ProgressParams SomeProgressParams
forall a b. (a -> b) -> a -> b
$
          WorkDoneProgressReportParams -> SomeProgressParams
LSP.Report (WorkDoneProgressReportParams -> SomeProgressParams)
-> WorkDoneProgressReportParams -> SomeProgressParams
forall a b. (a -> b) -> a -> b
$
            case ProgressReportingStyle
style of
                ProgressReportingStyle
Percentage -> WorkDoneProgressReportParams :: Maybe Bool
-> Maybe Text -> Maybe UInt -> WorkDoneProgressReportParams
LSP.WorkDoneProgressReportParams
                    { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                    , $sel:_message:WorkDoneProgressReportParams :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                    , $sel:_percentage:WorkDoneProgressReportParams :: Maybe UInt
_percentage = UInt -> Maybe UInt
forall a. a -> Maybe a
Just UInt
progressPct
                    }
                ProgressReportingStyle
Explicit -> WorkDoneProgressReportParams :: Maybe Bool
-> Maybe Text -> Maybe UInt -> WorkDoneProgressReportParams
LSP.WorkDoneProgressReportParams
                    { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                    , $sel:_message:WorkDoneProgressReportParams :: 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:WorkDoneProgressReportParams :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                    }
                ProgressReportingStyle
NoProgress -> WorkDoneProgressReportParams :: Maybe Bool
-> Maybe Text -> Maybe UInt -> WorkDoneProgressReportParams
LSP.WorkDoneProgressReportParams
                  { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                  , $sel:_message:WorkDoneProgressReportParams :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                  , $sel:_percentage:WorkDoneProgressReportParams :: Maybe UInt
_percentage = Maybe UInt
forall a. Maybe a
Nothing
                  }

    -- Report the progress once we are done indexing this file
    post :: IO ()
post = do
      Maybe Int
mdone <- STM (Maybe Int) -> IO (Maybe Int)
forall a. STM a -> IO a
atomically (STM (Maybe Int) -> IO (Maybe Int))
-> STM (Maybe Int) -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ do
        -- Remove current element from pending
        HashMap NormalizedFilePath Fingerprint
pending <- TVar (HashMap NormalizedFilePath Fingerprint)
-> (HashMap NormalizedFilePath Fingerprint
    -> (HashMap NormalizedFilePath Fingerprint,
        HashMap NormalizedFilePath Fingerprint))
-> STM (HashMap NormalizedFilePath Fingerprint)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar (HashMap NormalizedFilePath Fingerprint)
indexPending ((HashMap NormalizedFilePath Fingerprint
  -> (HashMap NormalizedFilePath Fingerprint,
      HashMap NormalizedFilePath Fingerprint))
 -> STM (HashMap NormalizedFilePath Fingerprint))
-> (HashMap NormalizedFilePath Fingerprint
    -> (HashMap NormalizedFilePath Fingerprint,
        HashMap NormalizedFilePath Fingerprint))
-> STM (HashMap NormalizedFilePath Fingerprint)
forall a b. (a -> b) -> a -> b
$
          HashMap NormalizedFilePath Fingerprint
-> (HashMap NormalizedFilePath Fingerprint,
    HashMap NormalizedFilePath Fingerprint)
forall a. a -> (a, a)
dupe (HashMap NormalizedFilePath Fingerprint
 -> (HashMap NormalizedFilePath Fingerprint,
     HashMap NormalizedFilePath Fingerprint))
-> (HashMap NormalizedFilePath Fingerprint
    -> HashMap NormalizedFilePath Fingerprint)
-> HashMap NormalizedFilePath Fingerprint
-> (HashMap NormalizedFilePath Fingerprint,
    HashMap NormalizedFilePath Fingerprint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fingerprint -> Maybe Fingerprint)
-> NormalizedFilePath
-> HashMap NormalizedFilePath Fingerprint
-> HashMap NormalizedFilePath Fingerprint
forall k a.
(Eq k, Hashable k) =>
(a -> Maybe a) -> k -> HashMap k a -> HashMap k a
HashMap.update (\Fingerprint
pendingHash -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Fingerprint
pendingHash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
hash) Maybe () -> Fingerprint -> Maybe Fingerprint
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Fingerprint
pendingHash) NormalizedFilePath
srcPath
        TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
indexCompleted (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        -- If we are done, report and reset completed
        Bool -> STM Int -> STM (Maybe Int)
forall (m :: * -> *) a. Applicative m => Bool -> m a -> m (Maybe a)
whenMaybe (HashMap NormalizedFilePath Fingerprint -> Bool
forall k v. HashMap k v -> Bool
HashMap.null HashMap NormalizedFilePath Fingerprint
pending) (STM Int -> STM (Maybe Int)) -> STM Int -> STM (Maybe Int)
forall a b. (a -> b) -> a -> b
$
          TVar Int -> Int -> STM Int
forall a. TVar a -> a -> STM a
swapTVar TVar Int
indexCompleted Int
0
      Maybe (LanguageContextEnv Config)
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) ((LanguageContextEnv Config -> IO ()) -> IO ())
-> (LanguageContextEnv Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env -> LanguageContextEnv Config -> LspT Config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Bool -> LspT Config IO () -> LspT Config IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IdeTesting -> Bool
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 'CustomMethod
-> MessageParams 'CustomMethod -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (Text -> SServerMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
LSP.SCustomMethod Text
"ghcide/reference/ready") (MessageParams 'CustomMethod -> LspT Config IO ())
-> MessageParams 'CustomMethod -> 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
tok ->
              SServerMethod 'Progress
-> MessageParams 'Progress -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Progress
LSP.SProgress (MessageParams 'Progress -> LspT Config IO ())
-> MessageParams 'Progress -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken
-> SomeProgressParams -> ProgressParams SomeProgressParams
forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams ProgressToken
tok (SomeProgressParams -> ProgressParams SomeProgressParams)
-> SomeProgressParams -> ProgressParams SomeProgressParams
forall a b. (a -> b) -> a -> b
$
                WorkDoneProgressEndParams -> SomeProgressParams
LSP.End (WorkDoneProgressEndParams -> SomeProgressParams)
-> WorkDoneProgressEndParams -> SomeProgressParams
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressEndParams :: Maybe Text -> WorkDoneProgressEndParams
LSP.WorkDoneProgressEndParams
                  { $sel:_message:WorkDoneProgressEndParams :: Maybe Text
_message = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"Finished indexing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
done) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" files"
                  }
          -- We are done with the current indexing cycle, so destroy the token
          Maybe ProgressToken -> IO (Maybe ProgressToken)
forall (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
    FilePath -> (FilePath -> IO ()) -> IO ()
forall a. FilePath -> (FilePath -> IO a) -> IO ()
atomicFileWrite 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 :: HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile 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
    FilePath -> (FilePath -> IO ()) -> IO ()
forall a. FilePath -> (FilePath -> IO a) -> IO ()
atomicFileWrite FilePath
targetPath ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fp ->
      HscEnv -> FilePath -> ModIface -> IO ()
writeIfaceFile HscEnv
hscEnv FilePath
fp ModIface
modIface
  where
    modIface :: ModIface
modIface = HomeModInfo -> ModIface
hm_iface (HomeModInfo -> ModIface) -> HomeModInfo -> ModIface
forall a b. (a -> b) -> a -> b
$ HiFileResult -> HomeModInfo
hirHomeMod 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FileDiagnostic] -> IO [FileDiagnostic]
forall (m :: * -> *) a. Monad m => a -> m a
return [] IO [FileDiagnostic]
-> [Handler IO [FileDiagnostic]] -> IO [FileDiagnostic]
forall (m :: * -> *) a.
(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 (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 (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
DsError (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 -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (SomeException -> FilePath) -> SomeException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Show SomeException => SomeException -> FilePath
forall a. Show a => a -> FilePath
show @SomeException
    ]

handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
handleGenerationErrors' :: 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 (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.
(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 (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 (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
DsError (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 -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (SomeException -> FilePath) -> SomeException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Show SomeException => SomeException -> FilePath
forall a. Show a => a -> FilePath
show @SomeException
    ]

-- | Load modules, quickly. Input doesn't need to be desugared.
-- A module must be loaded before dependent modules can be typechecked.
-- This variant of loadModuleHome will *never* cause recompilation, it just
-- modifies the session.
-- The order modules are loaded is important when there are hs-boot files.
-- In particular you should make sure to load the .hs version of a file after the
-- .hs-boot version.
loadModulesHome
    :: [HomeModInfo]
    -> HscEnv
    -> HscEnv
loadModulesHome :: [HomeModInfo] -> HscEnv -> HscEnv
loadModulesHome [HomeModInfo]
mod_infos HscEnv
e =
  let !new_modules :: HomePackageTable
new_modules = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
e) [(HomeModInfo -> ModuleName
mod_name HomeModInfo
x, HomeModInfo
x) | HomeModInfo
x <- [HomeModInfo]
mod_infos]
  in HscEnv
e { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_modules
      , hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = Maybe (Module, IORef TypeEnv)
forall a. Maybe a
Nothing }
    where
      mod_name :: HomeModInfo -> ModuleName
mod_name = Module -> ModuleName
moduleName (Module -> ModuleName)
-> (HomeModInfo -> Module) -> HomeModInfo -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface

-- Merge the HPTs, module graphs and FinderCaches
mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
mergeEnvs HscEnv
env [ModSummary]
extraModSummaries [HomeModInfo]
extraMods [HscEnv]
envs = do
    FinderCache
prevFinderCache <- [FinderCache] -> FinderCache
concatFC ([FinderCache] -> FinderCache)
-> IO [FinderCache] -> IO FinderCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HscEnv -> IO FinderCache) -> [HscEnv] -> IO [FinderCache]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IORef FinderCache -> IO FinderCache
forall a. IORef a -> IO a
readIORef (IORef FinderCache -> IO FinderCache)
-> (HscEnv -> IORef FinderCache) -> HscEnv -> IO FinderCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> IORef FinderCache
hsc_FC) [HscEnv]
envs
    let ims :: [InstalledModule]
ims  = (ModSummary -> InstalledModule)
-> [ModSummary] -> [InstalledModule]
forall a b. (a -> b) -> [a] -> [b]
map (\ModSummary
ms -> Unit -> ModuleName -> InstalledModule
Compat.installedModule (Unit -> Unit
toUnitId (Unit -> Unit) -> Unit -> Unit
forall a b. (a -> b) -> a -> b
$ Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms)  (Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms))) [ModSummary]
extraModSummaries
        ifrs :: [InstalledFindResult]
ifrs = (ModSummary -> InstalledModule -> InstalledFindResult)
-> [ModSummary] -> [InstalledModule] -> [InstalledFindResult]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ModSummary
ms -> ModLocation -> InstalledModule -> InstalledFindResult
InstalledFound (ModSummary -> ModLocation
ms_location ModSummary
ms)) [ModSummary]
extraModSummaries [InstalledModule]
ims
        -- Very important to force this as otherwise the hsc_mod_graph field is not
        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
        -- this new one, which in turn leads to the EPS referencing the HPT.
        module_graph_nodes :: [ModSummary]
module_graph_nodes =
#if MIN_VERSION_ghc(9,2,0)
        -- We don't do any instantiation for backpack at this point of time, so it is OK to use
        -- 'extendModSummaryNoDeps'.
        -- This may have to change in the future.
          map extendModSummaryNoDeps $
#endif
          [ModSummary]
extraModSummaries [ModSummary] -> [ModSummary] -> [ModSummary]
forall a. [a] -> [a] -> [a]
++ (ModSummary -> Module) -> [ModSummary] -> [ModSummary]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn ModSummary -> Module
ms_mod ((HscEnv -> [ModSummary]) -> [HscEnv] -> [ModSummary]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleGraph -> [ModSummary]
mgModSummaries (ModuleGraph -> [ModSummary])
-> (HscEnv -> ModuleGraph) -> HscEnv -> [ModSummary]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> ModuleGraph
hsc_mod_graph) [HscEnv]
envs)

    IORef FinderCache
newFinderCache <- FinderCache -> IO (IORef FinderCache)
forall a. a -> IO (IORef a)
newIORef (FinderCache -> IO (IORef FinderCache))
-> FinderCache -> IO (IORef FinderCache)
forall a b. (a -> b) -> a -> b
$
            (FinderCache
 -> (InstalledModule, InstalledFindResult) -> FinderCache)
-> FinderCache
-> [(InstalledModule, InstalledFindResult)]
-> FinderCache
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                (\FinderCache
fc (InstalledModule
im, InstalledFindResult
ifr) -> FinderCache
-> InstalledModule -> InstalledFindResult -> FinderCache
forall a.
InstalledModuleEnv a
-> InstalledModule -> a -> InstalledModuleEnv a
Compat.extendInstalledModuleEnv FinderCache
fc InstalledModule
im InstalledFindResult
ifr) FinderCache
prevFinderCache
                ([(InstalledModule, InstalledFindResult)] -> FinderCache)
-> [(InstalledModule, InstalledFindResult)] -> FinderCache
forall a b. (a -> b) -> a -> b
$ [InstalledModule]
-> [InstalledFindResult]
-> [(InstalledModule, InstalledFindResult)]
forall a b. [a] -> [b] -> [(a, b)]
zip [InstalledModule]
ims [InstalledFindResult]
ifrs
    (ModSummary -> ()) -> [ModSummary] -> ()
forall (f :: * -> *) a. NFData1 f => (a -> ()) -> f a -> ()
liftRnf ModSummary -> ()
forall a. a -> ()
rwhnf [ModSummary]
module_graph_nodes () -> IO HscEnv -> IO HscEnv
`seq` (HscEnv -> IO HscEnv
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
$ HscEnv
env{
        hsc_HPT :: HomePackageTable
hsc_HPT = (HomePackageTable -> HomePackageTable -> HomePackageTable)
-> HomePackageTable
-> (HscEnv -> HomePackageTable)
-> [HscEnv]
-> HomePackageTable
forall (t :: * -> *) r a.
Foldable t =>
(r -> r -> r) -> r -> (a -> r) -> t a -> r
foldMapBy HomePackageTable -> HomePackageTable -> HomePackageTable
mergeUDFM HomePackageTable
forall elt. UniqDFM elt
emptyUDFM HscEnv -> HomePackageTable
hsc_HPT [HscEnv]
envs,
        hsc_FC :: IORef FinderCache
hsc_FC = IORef FinderCache
newFinderCache,
        hsc_mod_graph :: ModuleGraph
hsc_mod_graph = [ModSummary] -> ModuleGraph
mkModuleGraph [ModSummary]
module_graph_nodes
    })
    where
        mergeUDFM :: HomePackageTable -> HomePackageTable -> HomePackageTable
mergeUDFM = (HomeModInfo -> HomeModInfo -> HomeModInfo)
-> HomePackageTable -> HomePackageTable -> HomePackageTable
forall elt.
(elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt
plusUDFM_C HomeModInfo -> HomeModInfo -> HomeModInfo
combineModules
        combineModules :: HomeModInfo -> HomeModInfo -> HomeModInfo
combineModules HomeModInfo
a HomeModInfo
b
          | HscSource
HsSrcFile <- ModIface -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src (HomeModInfo -> ModIface
hm_iface HomeModInfo
a) = HomeModInfo
a
          | Bool
otherwise = HomeModInfo
b
    -- required because 'FinderCache':
    --  1) doesn't have a 'Monoid' instance,
    --  2) is abstract and doesn't export constructors
    -- To work around this, we coerce to the underlying type
    -- To remove this, I plan to upstream the missing Monoid instance
        concatFC :: [FinderCache] -> FinderCache
        concatFC :: [FinderCache] -> FinderCache
concatFC = ([Map InstalledModule InstalledFindResult]
 -> Map InstalledModule InstalledFindResult)
-> [FinderCache] -> FinderCache
forall a b. a -> b
unsafeCoerce (Monoid (Map InstalledModule InstalledFindResult) =>
[Map InstalledModule InstalledFindResult]
-> Map InstalledModule InstalledFindResult
forall a. Monoid a => [a] -> a
mconcat @(Map InstalledModule InstalledFindResult))

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

-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
--   Runs preprocessors as needed.
getModSummaryFromImports
  :: HscEnv
  -> FilePath
  -> UTCTime
  -> Maybe Util.StringBuffer
  -> ExceptT [FileDiagnostic] IO ModSummaryResult
getModSummaryFromImports :: HscEnv
-> FilePath
-> UTCTime
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO ModSummaryResult
getModSummaryFromImports HscEnv
env FilePath
fp UTCTime
modTime Maybe StringBuffer
contents = do
    (StringBuffer
contents, [FilePath]
opts, DynFlags
dflags) <- HscEnv
-> FilePath
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO (StringBuffer, [FilePath], DynFlags)
preprocessor HscEnv
env FilePath
fp Maybe StringBuffer
contents

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

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

        mod :: ModuleName
mod = (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (Located ModuleName)
mb_mod Maybe ModuleName -> ModuleName -> ModuleName
forall a. Maybe a -> a -> a
`Util.orElse` ModuleName
mAIN_NAME

        ([LImportDecl GhcPs]
src_idecls, [LImportDecl GhcPs]
ord_idecls) = (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs]
-> ([LImportDecl GhcPs], [LImportDecl GhcPs])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
IsBoot) (Bool -> Bool)
-> (LImportDecl GhcPs -> Bool) -> LImportDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> Bool
forall pass. ImportDecl pass -> Bool
ideclSource(ImportDecl GhcPs -> Bool)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LImportDecl GhcPs -> ImportDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LImportDecl GhcPs]
imps

        -- GHC.Prim doesn't exist physically, so don't go looking for it.
        ordinary_imps :: [LImportDecl GhcPs]
ordinary_imps = (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
moduleName Module
gHC_PRIM) (ModuleName -> Bool)
-> (LImportDecl GhcPs -> ModuleName) -> LImportDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc
                                (Located ModuleName -> ModuleName)
-> (LImportDecl GhcPs -> Located ModuleName)
-> LImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName (ImportDecl GhcPs -> Located ModuleName)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> Located ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> ImportDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
                               [LImportDecl GhcPs]
ord_idecls

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

        convImport :: GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport (L l
_ ImportDecl pass
i) = ((StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (ImportDecl pass -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
i)
                                         , Located ModuleName -> Located ModuleName
forall a. Located a -> Located a
reLoc (Located ModuleName -> Located ModuleName)
-> Located ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl pass -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl pass
i)

        srcImports :: [(Maybe FastString, Located ModuleName)]
srcImports = (LImportDecl GhcPs -> (Maybe FastString, Located ModuleName))
-> [LImportDecl GhcPs] -> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs -> (Maybe FastString, Located ModuleName)
forall l pass.
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport [LImportDecl GhcPs]
src_idecls
        textualImports :: [(Maybe FastString, Located ModuleName)]
textualImports = (LImportDecl GhcPs -> (Maybe FastString, Located ModuleName))
-> [LImportDecl GhcPs] -> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs -> (Maybe FastString, Located ModuleName)
forall l pass.
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
ordinary_imps)

        msrImports :: [LImportDecl GhcPs]
msrImports = [LImportDecl GhcPs]
implicit_imports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
imps

    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily
    IO () -> ExceptT [FileDiagnostic] IO ()
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
$ [(Maybe FastString, Located ModuleName)] -> ()
forall a. NFData a => a -> ()
rnf [(Maybe FastString, Located ModuleName)]
srcImports
    IO () -> ExceptT [FileDiagnostic] IO ()
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
$ [(Maybe FastString, Located ModuleName)] -> ()
forall a. NFData a => a -> ()
rnf [(Maybe FastString, Located ModuleName)]
textualImports

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

    let modl :: Module
modl = Unit -> ModuleName -> Module
mkHomeModule (HscEnv -> Unit
hscHomeUnit (DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
env)) 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
        msrModSummary :: ModSummary
msrModSummary =
            ModSummary :: Module
-> HscSource
-> ModLocation
-> UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> Maybe HsParsedModule
-> FilePath
-> DynFlags
-> Maybe StringBuffer
-> ModSummary
ModSummary
                { ms_mod :: Module
ms_mod          = Module
modl
#if MIN_VERSION_ghc(8,8,0)
                , ms_hie_date :: Maybe UTCTime
ms_hie_date     = Maybe UTCTime
forall a. Maybe a
Nothing
#endif
                , ms_hs_date :: UTCTime
ms_hs_date      = UTCTime
modTime
                , ms_hsc_src :: HscSource
ms_hsc_src      = HscSource
sourceType
                -- The contents are used by the GetModSummary rule
                , ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf     = StringBuffer -> Maybe StringBuffer
forall a. a -> Maybe a
Just StringBuffer
contents
                , ms_hspp_file :: FilePath
ms_hspp_file    = FilePath
fp
                , ms_hspp_opts :: DynFlags
ms_hspp_opts    = DynFlags
dflags
                , ms_iface_date :: Maybe UTCTime
ms_iface_date   = Maybe UTCTime
forall a. Maybe a
Nothing
                , ms_location :: ModLocation
ms_location     = HscSource -> ModLocation -> ModLocation
withBootSuffix HscSource
sourceType ModLocation
modLoc
                , ms_obj_date :: Maybe UTCTime
ms_obj_date     = Maybe UTCTime
forall a. Maybe a
Nothing
                , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod   = Maybe HsParsedModule
forall a. Maybe a
Nothing
                , ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps      = [(Maybe FastString, Located ModuleName)]
srcImports
                , ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_textual_imps = [(Maybe FastString, Located ModuleName)]
textualImports
                }

    Fingerprint
msrFingerprint <- IO Fingerprint -> ExceptT [FileDiagnostic] IO Fingerprint
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
msrModSummary
    ModSummaryResult -> ExceptT [FileDiagnostic] IO ModSummaryResult
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummaryResult :: ModSummary
-> [LImportDecl GhcPs] -> Fingerprint -> ModSummaryResult
ModSummaryResult{[LImportDecl GhcPs]
Fingerprint
ModSummary
msrFingerprint :: Fingerprint
msrImports :: [LImportDecl GhcPs]
msrModSummary :: ModSummary
msrFingerprint :: Fingerprint
msrModSummary :: ModSummary
msrImports :: [LImportDecl GhcPs]
..}
    where
        -- Compute a fingerprint from the contents of `ModSummary`,
        -- eliding the timestamps, the preprocessed source and other non relevant fields
        computeFingerprint :: [FilePath] -> ModSummary -> IO Fingerprint
computeFingerprint [FilePath]
opts ModSummary{FilePath
[(Maybe FastString, Located ModuleName)]
Maybe UTCTime
Maybe HsParsedModule
Maybe StringBuffer
UTCTime
HscSource
ModLocation
Module
DynFlags
ms_hspp_buf :: Maybe StringBuffer
ms_hspp_opts :: DynFlags
ms_hspp_file :: FilePath
ms_parsed_mod :: Maybe HsParsedModule
ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_hie_date :: Maybe UTCTime
ms_iface_date :: Maybe UTCTime
ms_obj_date :: Maybe UTCTime
ms_hs_date :: UTCTime
ms_location :: ModLocation
ms_hsc_src :: HscSource
ms_mod :: Module
ms_textual_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_srcimps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_parsed_mod :: ModSummary -> Maybe HsParsedModule
ms_obj_date :: ModSummary -> Maybe UTCTime
ms_iface_date :: ModSummary -> Maybe UTCTime
ms_hspp_file :: ModSummary -> FilePath
ms_hspp_buf :: ModSummary -> Maybe StringBuffer
ms_hsc_src :: ModSummary -> HscSource
ms_hs_date :: ModSummary -> UTCTime
ms_hie_date :: ModSummary -> Maybe UTCTime
ms_mod :: ModSummary -> Module
ms_location :: ModSummary -> ModLocation
ms_hspp_opts :: ModSummary -> DynFlags
..} = do
            Fingerprint
fingerPrintImports <- Put -> IO Fingerprint
fingerprintFromPut (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
moduleName Module
ms_mod
                  [(Maybe FastString, Located ModuleName)]
-> ((Maybe FastString, Located ModuleName) -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Maybe FastString, Located ModuleName)]
ms_srcimps [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, Located ModuleName)]
ms_textual_imps) (((Maybe FastString, Located ModuleName) -> Put) -> Put)
-> ((Maybe FastString, Located ModuleName) -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \(Maybe FastString
mb_p, Located 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
$ Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
m
                    Maybe FastString -> (FastString -> Put) -> Put
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe FastString
mb_p ((FastString -> Put) -> Put) -> (FastString -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Put
forall t. Binary t => t -> Put
put (Int -> Put) -> (FastString -> Int) -> FastString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Int
Util.uniq
            Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$! [Fingerprint] -> Fingerprint
Util.fingerprintFingerprints ([Fingerprint] -> Fingerprint) -> [Fingerprint] -> Fingerprint
forall a b. (a -> b) -> a -> b
$
                    [ FilePath -> Fingerprint
Util.fingerprintString FilePath
fp
                    , Fingerprint
fingerPrintImports
                    ] [Fingerprint] -> [Fingerprint] -> [Fingerprint]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Fingerprint) -> [FilePath] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Fingerprint
Util.fingerprintString [FilePath]
opts


-- | Parse only the module header
parseHeader
       :: Monad m
       => DynFlags -- ^ flags to use
       -> FilePath  -- ^ the filename (for source locations)
       -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
#if MIN_VERSION_ghc(9,0,1)
       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule))
#else
       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))
#endif
parseHeader :: DynFlags
-> FilePath
-> StringBuffer
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
parseHeader DynFlags
dflags FilePath
filename StringBuffer
contents = do
   let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
Util.mkFastString FilePath
filename) Int
1 Int
1
   case P ParsedSource -> PState -> ParseResult ParsedSource
forall a. P a -> PState -> ParseResult a
unP P ParsedSource
Compat.parseHeader (DynFlags -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> DynFlags
initParserOpts DynFlags
dflags) StringBuffer
contents RealSrcLoc
loc) of
     PFailedWithErrorMessages DynFlags -> ErrorMessages
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 -> ErrorMessages -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags (ErrorMessages -> [FileDiagnostic])
-> ErrorMessages -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ DynFlags -> ErrorMessages
msgs DynFlags
dflags
     POk PState
pst ParsedSource
rdr_module -> do
        let (ErrorMessages
warns, ErrorMessages
errs) = PState -> DynFlags -> (ErrorMessages, ErrorMessages)
getMessages' PState
pst DynFlags
dflags

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

        let warnings :: [FileDiagnostic]
warnings = Text -> DynFlags -> ErrorMessages -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags ErrorMessages
warns
        ([FileDiagnostic], ParsedSource)
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
warnings, ParsedSource
rdr_module)

-- | Given a buffer, flags, and file path, produce a
-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
-- ModSummary must contain the (preprocessed) contents of the buffer
parseFileContents
       :: HscEnv
       -> (GHC.ParsedSource -> IdePreprocessedSource)
       -> FilePath  -- ^ the filename (for source locations)
       -> ModSummary
       -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
parseFileContents :: HscEnv
-> (ParsedSource -> IdePreprocessedSource)
-> FilePath
-> ModSummary
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
parseFileContents HscEnv
env ParsedSource -> IdePreprocessedSource
customPreprocessor FilePath
filename ModSummary
ms = do
   let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
Util.mkFastString FilePath
filename) Int
1 Int
1
       dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
       contents :: StringBuffer
contents = Maybe StringBuffer -> StringBuffer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe StringBuffer -> StringBuffer)
-> Maybe StringBuffer -> StringBuffer
forall a b. (a -> b) -> a -> b
$ ModSummary -> Maybe StringBuffer
ms_hspp_buf ModSummary
ms
   case P ParsedSource -> PState -> ParseResult ParsedSource
forall a. P a -> PState -> ParseResult a
unP P ParsedSource
Compat.parseModule (DynFlags -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> DynFlags
initParserOpts DynFlags
dflags) StringBuffer
contents RealSrcLoc
loc) of
     PFailedWithErrorMessages DynFlags -> ErrorMessages
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 -> ErrorMessages -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags (ErrorMessages -> [FileDiagnostic])
-> ErrorMessages -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ DynFlags -> ErrorMessages
msgs DynFlags
dflags
     POk PState
pst ParsedSource
rdr_module ->
         let
             hpm_annotations :: ApiAnns
hpm_annotations = PState -> ApiAnns
mkApiAnns PState
pst
             (ErrorMessages
warns, ErrorMessages
errs) = PState -> DynFlags -> (ErrorMessages, ErrorMessages)
getMessages' PState
pst DynFlags
dflags
         in
           do
               -- Just because we got a `POk`, it doesn't mean there
               -- weren't errors! To clarify, the GHC parser
               -- distinguishes between fatal and non-fatal
               -- errors. Non-fatal errors are the sort that don't
               -- prevent parsing from continuing (that is, a parse
               -- tree can still be produced despite the error so that
               -- further errors/warnings can be collected). Fatal
               -- errors are those from which a parse tree just can't
               -- be produced.
               Bool
-> ExceptT [FileDiagnostic] IO () -> ExceptT [FileDiagnostic] IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ErrorMessages -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ErrorMessages
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 -> DynFlags -> ErrorMessages -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags ErrorMessages
errs

               -- Ok, we got here. It's safe to continue.
               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 (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
"parser" DiagnosticSeverity
DsError [(SrcSpan, FilePath)]
errs

               let preproc_warnings :: [FileDiagnostic]
preproc_warnings = Text
-> DiagnosticSeverity -> [(SrcSpan, FilePath)] -> [FileDiagnostic]
diagFromStrings Text
"parser" DiagnosticSeverity
DsWarning [(SrcSpan, FilePath)]
preproc_warns
               ParsedSource
parsed' <- IO ParsedSource -> ExceptT [FileDiagnostic] IO ParsedSource
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ParsedSource -> ExceptT [FileDiagnostic] IO ParsedSource)
-> IO ParsedSource -> ExceptT [FileDiagnostic] IO ParsedSource
forall a b. (a -> b) -> a -> b
$ HscEnv
-> DynFlags
-> ModSummary
-> ApiAnns
-> ParsedSource
-> IO ParsedSource
applyPluginsParsedResultAction HscEnv
env DynFlags
dflags ModSummary
ms ApiAnns
hpm_annotations ParsedSource
parsed

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

               -- sometimes we see source files from earlier
               -- preprocessing stages that cannot be found, so just
               -- filter them out:
               [FilePath]
srcs2 <- IO [FilePath] -> ExceptT [FileDiagnostic] IO [FilePath]
forall (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] -> ApiAnns -> ParsedModule
ParsedModule ModSummary
ms ParsedSource
parsed' [FilePath]
srcs2 ApiAnns
hpm_annotations
                   warnings :: [FileDiagnostic]
warnings = Text -> DynFlags -> ErrorMessages -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags ErrorMessages
warns
               ([FileDiagnostic], ParsedModule)
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
warnings [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
forall a. [a] -> [a] -> [a]
++ [FileDiagnostic]
preproc_warnings, ParsedModule
pm)

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


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

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

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

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

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

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

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

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

Then when deciding whether to recompile, we need to check that the versions
of the linkables used during a previous compile match whatever is currently
in the HPT.
-}

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

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

        obj_file :: FilePath
obj_file = ModLocation -> FilePath
ml_obj_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 (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 (NormalizedFilePath -> m (Maybe FileVersion))
-> NormalizedFilePath -> m (Maybe FileVersion)
forall a b. (a -> b) -> a -> b
$ FilePath -> NormalizedFilePath
toNormalizedFilePath' (FilePath -> NormalizedFilePath) -> FilePath -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ case Maybe LinkableType
linkableNeeded of
          Just LinkableType
ObjectLinkable -> ModLocation -> FilePath
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
          Maybe LinkableType
_                   -> ModLocation -> FilePath
ml_hi_file (ModSummary -> ModLocation
ms_location ModSummary
ms)

    -- The source is modified if it is newer than the destination
    let sourceMod :: SourceModified
sourceMod = case Maybe FileVersion
mb_dest_version of
          Maybe FileVersion
Nothing -> SourceModified
SourceModified -- desitination file doesn't exist, assume modified source
          Just FileVersion
dest_version
            | FileVersion
source_version FileVersion -> FileVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= FileVersion
dest_version -> SourceModified
SourceUnmodified
            | Bool
otherwise -> SourceModified
SourceModified

    -- If mb_old_iface is nothing then checkOldIface will load it for us
    (RecompileRequired
recomp_iface_reqd, Maybe ModIface
mb_checked_iface)
      <- IO (RecompileRequired, Maybe ModIface)
-> m (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RecompileRequired, Maybe ModIface)
 -> m (RecompileRequired, Maybe ModIface))
-> IO (RecompileRequired, Maybe ModIface)
-> m (RecompileRequired, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface HscEnv
sessionWithMsDynFlags ModSummary
ms SourceModified
sourceMod Maybe ModIface
mb_old_iface


    let
      (RecompileRequired
recomp_obj_reqd, Maybe Linkable
mb_linkable) = case Maybe LinkableType
linkableNeeded of
        Maybe LinkableType
Nothing -> (RecompileRequired
UpToDate, Maybe Linkable
forall a. Maybe a
Nothing)
        Just LinkableType
linkableType -> case Maybe (HiFileResult, FileVersion)
old_value of
          -- We don't have an old result
          Maybe (HiFileResult, FileVersion)
Nothing -> FilePath -> (RecompileRequired, Maybe Linkable)
recompMaybeBecause FilePath
"missing"
          -- We have an old result
          Just (HiFileResult
old_hir, FileVersion
old_file_version) ->
            case HomeModInfo -> Maybe Linkable
hm_linkable (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Maybe Linkable
forall a b. (a -> b) -> a -> b
$ HiFileResult -> HomeModInfo
hirHomeMod HiFileResult
old_hir of
              Maybe Linkable
Nothing -> FilePath -> (RecompileRequired, Maybe Linkable)
recompMaybeBecause FilePath
"missing [not needed before]"
              Just Linkable
old_lb
                | Just Bool
True <- ModIface -> Bool
forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th (ModIface -> Bool) -> Maybe ModIface -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModIface
mb_checked_iface -- No need to recompile if TH wasn't used
                , FileVersion
old_file_version FileVersion -> FileVersion -> Bool
forall a. Eq a => a -> a -> Bool
/= FileVersion
source_version -> FilePath -> (RecompileRequired, Maybe Linkable)
recompMaybeBecause FilePath
"out of date"

                -- Check if it is the correct type
                -- Ideally we could use object-code in case we already have
                -- it when we are generating bytecode, but this is difficult because something
                -- below us may be bytecode, and object code can't depend on bytecode
                | LinkableType
ObjectLinkable <- LinkableType
linkableType, Linkable -> Bool
isObjectLinkable Linkable
old_lb
                -> (RecompileRequired
UpToDate, Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
old_lb)

                | LinkableType
BCOLinkable    <- LinkableType
linkableType , Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
old_lb)
                -> (RecompileRequired
UpToDate, Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
old_lb)

                | Bool
otherwise -> FilePath -> (RecompileRequired, Maybe Linkable)
recompMaybeBecause FilePath
"missing [wrong type]"
          where
            recompMaybeBecause :: FilePath -> (RecompileRequired, Maybe Linkable)
recompMaybeBecause FilePath
msg = case LinkableType
linkableType of
              LinkableType
BCOLinkable -> (FilePath -> RecompileRequired
RecompBecause (FilePath
"bytecode "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg), Maybe Linkable
forall a. Maybe a
Nothing)
              LinkableType
ObjectLinkable -> case Maybe FileVersion
mb_dest_version of -- The destination file should be the object code
                Maybe FileVersion
Nothing -> (FilePath -> RecompileRequired
RecompBecause (FilePath
"object code "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg), Maybe Linkable
forall a. Maybe a
Nothing)
                Just disk_obj_version :: FileVersion
disk_obj_version@(ModificationTime POSIXTime
t) ->
                  -- If we make it this far, assume that the object code on disk is up to date
                  -- This assertion works because of the sourceMod check
                  Bool
-> (RecompileRequired, Maybe Linkable)
-> (RecompileRequired, Maybe Linkable)
forall a. HasCallStack => Bool -> a -> a
assert (FileVersion
disk_obj_version FileVersion -> FileVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= FileVersion
source_version)
                         (RecompileRequired
UpToDate, Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just (Linkable -> Maybe Linkable) -> Linkable -> Maybe Linkable
forall a b. (a -> b) -> a -> b
$ UTCTime -> Module -> [Unlinked] -> Linkable
LM (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
t) Module
mod [FilePath -> Unlinked
DotO FilePath
obj_file])
                Just (VFSVersion Int32
_) -> FilePath -> (RecompileRequired, Maybe Linkable)
forall a. HasCallStack => FilePath -> a
error FilePath
"object code in vfs"

    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
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 (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
moduleName Module
mod, RecompileRequired -> FilePath
showReason RecompileRequired
_reason)
          Maybe LinkableType -> m (IdeResult HiFileResult)
regenerate Maybe LinkableType
linkableNeeded

    case (Maybe ModIface
mb_checked_iface, RecompileRequired
recomp_iface_reqd RecompileRequired -> RecompileRequired -> RecompileRequired
forall a. Semigroup a => a -> a -> a
<> RecompileRequired
recomp_obj_reqd) of
      (Just ModIface
iface, RecompileRequired
UpToDate) -> do
         -- Force it because we don't want to retain old modsummaries or linkables
         Maybe Linkable
lb <- IO (Maybe Linkable) -> m (Maybe Linkable)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Linkable) -> m (Maybe Linkable))
-> IO (Maybe Linkable) -> m (Maybe Linkable)
forall a b. (a -> b) -> a -> b
$ Maybe Linkable -> IO (Maybe Linkable)
forall a. a -> IO a
evaluate (Maybe Linkable -> IO (Maybe Linkable))
-> Maybe Linkable -> IO (Maybe Linkable)
forall a b. (a -> b) -> a -> b
$ Maybe Linkable -> Maybe Linkable
forall a. NFData a => a -> a
force Maybe Linkable
mb_linkable

         -- If we have an old value, just return it
         case Maybe (HiFileResult, FileVersion)
old_value of
           Just (HiFileResult
old_hir, FileVersion
_)
             | Just RecompileRequired
msg <- HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired
checkLinkableDependencies (HscEnv -> HomePackageTable
hsc_HPT HscEnv
sessionWithMsDynFlags) (HiFileResult -> ModuleEnv UTCTime
hirRuntimeModules HiFileResult
old_hir)
             -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate RecompileRequired
msg
             | Bool
otherwise -> IdeResult HiFileResult -> m (IdeResult HiFileResult)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], HiFileResult -> Maybe HiFileResult
forall a. a -> Maybe a
Just HiFileResult
old_hir)
           Maybe (HiFileResult, FileVersion)
Nothing -> do
             HomeModInfo
hmi <- IO HomeModInfo -> m HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> m HomeModInfo)
-> IO HomeModInfo -> m HomeModInfo
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo
mkDetailsFromIface HscEnv
sessionWithMsDynFlags ModIface
iface Maybe Linkable
lb
             -- parse the runtime dependencies from the annotations
             let runtime_deps :: ModuleEnv UTCTime
runtime_deps
                   | Bool -> Bool
not (ModIface -> Bool
forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th ModIface
iface) = ModuleEnv UTCTime
forall a. ModuleEnv a
emptyModuleEnv
                   | Bool
otherwise = [Annotation] -> ModuleEnv UTCTime
parseRuntimeDeps (ModDetails -> [Annotation]
md_anns (HomeModInfo -> ModDetails
hm_details HomeModInfo
hmi))
             IdeResult HiFileResult -> m (IdeResult HiFileResult)
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 -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult
mkHiFileResult ModSummary
ms HomeModInfo
hmi ModuleEnv UTCTime
runtime_deps)
      (Maybe ModIface
_, RecompileRequired
_reason) -> RecompileRequired -> m (IdeResult HiFileResult)
do_regenerate RecompileRequired
_reason

-- | ModDepTime is stored as an annotation in the iface to
-- keep track of runtime dependencies
newtype ModDepTime = ModDepTime UTCTime

deserializeModDepTime :: [Word8] -> ModDepTime
deserializeModDepTime :: [Word8] -> ModDepTime
deserializeModDepTime [Word8]
xs = UTCTime -> ModDepTime
ModDepTime (UTCTime -> ModDepTime) -> UTCTime -> ModDepTime
forall a b. (a -> b) -> a -> b
$ case ByteString -> (Int, Int)
forall a. Binary a => ByteString -> a
decode ([Word8] -> ByteString
LBS.pack [Word8]
xs) of
  (Int
a,Int
b) -> Day -> DiffTime -> UTCTime
UTCTime (Int -> Day
forall a. Enum a => Int -> a
toEnum Int
a) (Int -> DiffTime
forall a. Enum a => Int -> a
toEnum Int
b)

serializeModDepTime :: ModDepTime -> [Word8]
serializeModDepTime :: ModDepTime -> [Word8]
serializeModDepTime (ModDepTime UTCTime
l) = ByteString -> [Word8]
LBS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$
  (Int, Int) -> ByteString
forall a. Binary a => a -> ByteString
B.encode (Day -> Int
forall a. Enum a => a -> Int
fromEnum (Day -> Int) -> Day -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay UTCTime
l, DiffTime -> Int
forall a. Enum a => a -> Int
fromEnum (DiffTime -> Int) -> DiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime UTCTime
l)

-- | Find the runtime dependencies by looking at the annotations
-- serialized in the iface
parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime
parseRuntimeDeps :: [Annotation] -> ModuleEnv UTCTime
parseRuntimeDeps [Annotation]
anns = [(Module, UTCTime)] -> ModuleEnv UTCTime
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv ([(Module, UTCTime)] -> ModuleEnv UTCTime)
-> [(Module, UTCTime)] -> ModuleEnv UTCTime
forall a b. (a -> b) -> a -> b
$ (Annotation -> Maybe (Module, UTCTime))
-> [Annotation] -> [(Module, UTCTime)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Annotation -> Maybe (Module, UTCTime)
go [Annotation]
anns
  where
    go :: Annotation -> Maybe (Module, UTCTime)
go (Annotation (ModuleTarget Module
mod) Serialized
payload)
      | Just (ModDepTime UTCTime
t) <- ([Word8] -> ModDepTime) -> Serialized -> Maybe ModDepTime
forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized [Word8] -> ModDepTime
deserializeModDepTime Serialized
payload
      = (Module, UTCTime) -> Maybe (Module, UTCTime)
forall a. a -> Maybe a
Just (Module
mod, UTCTime
t)
    go Annotation
_ = Maybe (Module, UTCTime)
forall a. Maybe a
Nothing

-- | checkLinkableDependencies compares the linkables in the home package to
-- the runtime dependencies of the module, to check if any of them are out of date
-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
-- See Note [Recompilation avoidance in the presence of TH]
checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired
checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired
checkLinkableDependencies HomePackageTable
hpt ModuleEnv UTCTime
runtime_deps
  | ModuleEnv UTCTime -> Bool
forall a. ModuleEnv a -> Bool
isEmptyModuleEnv ModuleEnv UTCTime
out_of_date = Maybe RecompileRequired
forall a. Maybe a
Nothing -- Nothing out of date, so don't recompile
  | Bool
otherwise = 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
", " ((Module -> FilePath) -> [Module] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Module -> FilePath
forall a. Show a => a -> FilePath
show (ModuleEnv UTCTime -> [Module]
forall a. ModuleEnv a -> [Module]
moduleEnvKeys ModuleEnv UTCTime
out_of_date))
  where
    out_of_date :: ModuleEnv UTCTime
out_of_date = (Module -> UTCTime -> Bool)
-> ModuleEnv UTCTime -> ModuleEnv UTCTime
forall a. (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
filterModuleEnv (\Module
mod UTCTime
time -> case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (Module -> ModuleName
moduleName Module
mod) of
                                                  Maybe HomeModInfo
Nothing -> Bool
False
                                                  Just HomeModInfo
hm -> case HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hm of
                                                    Maybe Linkable
Nothing -> Bool
False
                                                    Just Linkable
lm -> Linkable -> UTCTime
linkableTime Linkable
lm UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= UTCTime
time)
                                  ModuleEnv UTCTime
runtime_deps

showReason :: RecompileRequired -> String
showReason :: RecompileRequired -> FilePath
showReason RecompileRequired
UpToDate          = FilePath
"UpToDate"
showReason RecompileRequired
MustCompile       = FilePath
"MustCompile"
showReason (RecompBecause FilePath
s) = FilePath
s

mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo
mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo
mkDetailsFromIface HscEnv
session ModIface
iface Maybe Linkable
linkable = do
  ModDetails
details <- IO ModDetails -> IO ModDetails
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModDetails -> IO ModDetails) -> IO ModDetails -> IO ModDetails
forall a b. (a -> b) -> a -> b
$ (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' = HscEnv
session { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
session) (Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) (ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details Maybe Linkable
linkable) }
    HscEnv -> IfG ModDetails -> IO ModDetails
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc' (ModIface -> IfG ModDetails
typecheckIface ModIface
iface)
  HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details Maybe Linkable
linkable)

-- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
--   The interactive paths create problems in ghc-lib builds
--- and leads to fun errors like "Cannot continue after interface file error".
getDocsBatch
  :: HscEnv
  -> Module  -- ^ a moudle where the names are in scope
  -> [Name]
  -> IO [Either String (Maybe HsDocString, IntMap HsDocString)]
getDocsBatch :: HscEnv
-> Module
-> [Name]
-> IO [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
getDocsBatch HscEnv
hsc_env Module
_mod [Name]
_names = do
    ((ErrorMessages, ErrorMessages)
msgs, Maybe
  [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
res) <- HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
-> IO
     ((ErrorMessages, ErrorMessages),
      Maybe
        [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)])
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO ((ErrorMessages, ErrorMessages), Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
_mod RealSrcSpan
fakeSpan (TcM
   [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
 -> IO
      ((ErrorMessages, ErrorMessages),
       Maybe
         [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]))
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
-> IO
     ((ErrorMessages, ErrorMessages),
      Maybe
        [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)])
forall a b. (a -> b) -> a -> b
$ [Name]
-> (Name
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)))
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
_names ((Name
  -> IOEnv
       (Env TcGblEnv TcLclEnv)
       (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)))
 -> TcM
      [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)])
-> (Name
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)))
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
forall a b. (a -> b) -> a -> b
$ \Name
name ->
        case Name -> Maybe Module
nameModule_maybe Name
name of
            Maybe Module
Nothing -> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return (GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
forall a b. a -> Either a b
Left (GetDocsFailure
 -> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
-> GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
forall a b. (a -> b) -> a -> b
$ Name -> GetDocsFailure
NameHasNoModule Name
name)
            Just Module
mod -> do
             ModIface { mi_doc_hdr :: forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe HsDocString
mi_doc_hdr = Maybe HsDocString
mb_doc_hdr
                      , mi_decl_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> DeclDocMap
mi_decl_docs = DeclDocMap Map Name HsDocString
dmap
                      , mi_arg_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> ArgDocMap
mi_arg_docs = ArgDocMap Map Name (Map Int HsDocString)
amap
                      } <- SDoc -> Module -> TcM ModIface
loadModuleInterface SDoc
"getModuleInterface" Module
mod
             if Maybe HsDocString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe HsDocString
mb_doc_hdr Bool -> Bool -> Bool
&& Map Name HsDocString -> Bool
forall k a. Map k a -> Bool
Map.null Map Name HsDocString
dmap Bool -> Bool -> Bool
&& Map Name (Map Int HsDocString) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Name (Map Int HsDocString)
amap
               then Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
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 HsDocString, IntMap HsDocString)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe HsDocString, IntMap HsDocString)
-> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
forall a b. b -> Either a b
Right ( Name -> Map Name HsDocString -> Maybe HsDocString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name HsDocString
dmap ,
#if !MIN_VERSION_ghc(9,2,0)
                                  [(Int, HsDocString)] -> IntMap HsDocString
forall a. [(Int, a)] -> IntMap a
IntMap.fromAscList ([(Int, HsDocString)] -> IntMap HsDocString)
-> [(Int, HsDocString)] -> IntMap HsDocString
forall a b. (a -> b) -> a -> b
$ Map Int HsDocString -> [(Int, HsDocString)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map Int HsDocString -> [(Int, HsDocString)])
-> Map Int HsDocString -> [(Int, HsDocString)]
forall a b. (a -> b) -> a -> b
$
#endif
                                  Map Int HsDocString
-> Name -> Map Name (Map Int HsDocString) -> Map Int HsDocString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Int HsDocString
forall a. Monoid a => a
mempty Name
name Map Name (Map Int HsDocString)
amap))
    case Maybe
  [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
res of
        Just [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
x  -> [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
-> IO [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either FilePath (Maybe HsDocString, IntMap HsDocString)]
 -> IO [Either FilePath (Maybe HsDocString, IntMap HsDocString)])
-> [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
-> IO [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
forall a b. (a -> b) -> a -> b
$ (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
 -> Either FilePath (Maybe HsDocString, IntMap HsDocString))
-> [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
-> [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
forall a b. (a -> b) -> [a] -> [b]
map ((GetDocsFailure -> FilePath)
-> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
-> Either FilePath (Maybe HsDocString, IntMap HsDocString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((GetDocsFailure -> FilePath)
 -> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
 -> Either FilePath (Maybe HsDocString, IntMap HsDocString))
-> (GetDocsFailure -> FilePath)
-> Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)
-> Either FilePath (Maybe HsDocString, IntMap HsDocString)
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 HsDocString, IntMap HsDocString)]
x
        Maybe
  [Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)]
Nothing -> ErrorMessages
-> IO [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
forall a. ErrorMessages -> IO a
throwErrors
#if MIN_VERSION_ghc(9,2,0)
                     $ Error.getErrorMessages msgs
#else
                     (ErrorMessages
 -> IO [Either FilePath (Maybe HsDocString, IntMap HsDocString)])
-> ErrorMessages
-> IO [Either FilePath (Maybe HsDocString, IntMap HsDocString)]
forall a b. (a -> b) -> a -> b
$ (ErrorMessages, ErrorMessages) -> ErrorMessages
forall a b. (a, b) -> b
snd (ErrorMessages, ErrorMessages)
msgs
#endif
  where
    throwErrors :: ErrorMessages -> IO a
throwErrors = IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> (ErrorMessages -> IO a) -> ErrorMessages -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (SourceError -> IO a)
-> (ErrorMessages -> SourceError) -> ErrorMessages -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> SourceError
mkSrcErr
    compiled :: Name -> Bool
compiled Name
n =
      -- TODO: Find a more direct indicator.
      case Name -> SrcLoc
nameSrcLoc Name
n of
        RealSrcLoc {}   -> Bool
False
        UnhelpfulLoc {} -> Bool
True

fakeSpan :: RealSrcSpan
fakeSpan :: RealSrcSpan
fakeSpan = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
Util.fsLit FilePath
"<ghcide>") Int
1 Int
1

-- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.
--   The interactive paths create problems in ghc-lib builds
--- and leads to fun errors like "Cannot continue after interface file error".
lookupName :: HscEnv
           -> Module -- ^ A module where the Names are in scope
           -> Name
           -> IO (Maybe TyThing)
lookupName :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
lookupName HscEnv
hsc_env Module
mod Name
name = do
    ((ErrorMessages, ErrorMessages)
_messages, Maybe TyThing
res) <- HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM TyThing
-> IO ((ErrorMessages, ErrorMessages), Maybe TyThing)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO ((ErrorMessages, ErrorMessages), Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
mod RealSrcSpan
fakeSpan (TcM TyThing -> IO ((ErrorMessages, ErrorMessages), Maybe TyThing))
-> TcM TyThing
-> IO ((ErrorMessages, ErrorMessages), Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ do
        TcTyThing
tcthing <- Name -> TcM TcTyThing
tcLookup Name
name
        case TcTyThing
tcthing of
            AGlobal TyThing
thing    -> TyThing -> TcM TyThing
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
            ATcId{tct_id :: TcTyThing -> Id
tct_id=Id
id} -> TyThing -> TcM TyThing
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> TyThing
AnId Id
id)
            TcTyThing
_                -> FilePath -> TcM TyThing
forall a. FilePath -> a
panic FilePath
"tcRnLookupName'"
    Maybe TyThing -> IO (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TyThing
res


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