-- 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
  , loadModulesHome
  , getDocsBatch
  , lookupName
  ,mergeEnvs) where

import           Development.IDE.Core.Preprocessor
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake
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           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           HieDb

import           Language.LSP.Types                (DiagnosticTag (..))

#if MIN_VERSION_ghc(8,10,0)
import           Control.DeepSeq                   (force, liftRnf, rnf, rwhnf)
#else
import           Control.DeepSeq                   (liftRnf, rnf, rwhnf)
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 qualified GHC.Types.Error                   as Error
#endif

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.Bifunctor                    (first, second)
import qualified Data.ByteString                   as BS
import qualified Data.DList                        as DL
import           Data.IORef
import qualified Data.IntMap.Strict                as IntMap
import           Data.List.Extra
import qualified Data.Map.Strict                   as Map
import           Data.Maybe
import qualified Data.Text                         as T
import           Data.Time                         (UTCTime, getCurrentTime)
import qualified GHC.LanguageExtensions            as LangExt
import           System.Directory
import           System.FilePath
import           System.IO.Extra                   (fixIO, newTempFileWithin)

-- GHC API imports
-- GHC API imports
import           GHC                               (GetDocsFailure (..),
                                                    mgModSummaries,
                                                    parsedSource)

import           Control.Concurrent.Extra
import           Control.Concurrent.STM.Stats      hiding (orElse)
import           Data.Aeson                        (toJSON)
import           Data.Binary
import           Data.Coerce
import           Data.Functor
import qualified Data.HashMap.Strict               as HashMap
import           Data.IntMap                       (IntMap)
import           Data.Map                          (Map)
import           Data.Tuple.Extra                  (dupe)
import           Data.Unique                       as Unique
import           Development.IDE.Core.Tracing      (withTrace)
import           Development.IDE.GHC.Compat.Util   (emptyUDFM, plusUDFM_C)
import qualified Language.LSP.Server               as LSP
import qualified Language.LSP.Types                as LSP
import           Unsafe.Coerce

-- | 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
                -> [Linkable] -- ^ linkables not to unload
                -> ParsedModule
                -> IO (IdeResult TcModuleResult)
typecheckModule :: IdeDefer
-> HscEnv
-> [Linkable]
-> ParsedModule
-> IO (IdeResult TcModuleResult)
typecheckModule (IdeDefer Bool
defer) HscEnv
hsc [Linkable]
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 -> [Linkable] -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
session [Linkable]
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

-- | Add a Hook to the DynFlags which captures and returns the
-- typechecked splices before they are run. This information
-- is used for hover.
captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices)
captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices)
captureSplices 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
  a
res <- HscEnv -> IO a
k (Hooks -> HscEnv -> HscEnv
hscSetHooks (IORef Splices -> Hooks -> Hooks
addSpliceHook IORef Splices
splice_ref (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
  (a, Splices) -> IO (a, Splices)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Splices
splices)
  where
    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 -> [Linkable] -> ParsedModule -> IO TcModuleResult
tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
hsc_env [Linkable]
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

  HscEnv -> [Linkable] -> IO ()
unload HscEnv
hsc_env_tmp [Linkable]
keep_lbls

  ((TcGblEnv
tc_gbl_env, RenamedStuff
mrn_info), Splices
splices)
      <- IO ((TcGblEnv, RenamedStuff), Splices)
-> IO ((TcGblEnv, RenamedStuff), Splices)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((TcGblEnv, RenamedStuff), Splices)
 -> IO ((TcGblEnv, RenamedStuff), Splices))
-> IO ((TcGblEnv, RenamedStuff), Splices)
-> IO ((TcGblEnv, RenamedStuff), Splices)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> (HscEnv -> IO (TcGblEnv, RenamedStuff))
-> IO ((TcGblEnv, RenamedStuff), Splices)
forall a. HscEnv -> (HscEnv -> IO a) -> IO (a, Splices)
captureSplices HscEnv
hsc_env_tmp ((HscEnv -> IO (TcGblEnv, RenamedStuff))
 -> IO ((TcGblEnv, RenamedStuff), Splices))
-> (HscEnv -> IO (TcGblEnv, RenamedStuff))
-> IO ((TcGblEnv, RenamedStuff), Splices)
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"
  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
-> TcModuleResult
TcModuleResult ParsedModule
pmod (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
 Maybe LHsDocString)
rn_info TcGblEnv
tc_gbl_env Splices
splices Bool
False)

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 -> HiFileResult
mkHiFileResult ModSummary
ms HomeModInfo
mod_info

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 -> HiFileResult
mkHiFileResult ModSummary
ms HomeModInfo
mod_info)

  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

-- | Retuns an up-to-date module interface, regenerating if needed.
--   Assumes file exists.
--   Requires the 'HscEnv' to be set up with dependencies
loadInterface
  :: (MonadIO m, MonadMask m)
  => HscEnv
  -> ModSummary
  -> SourceModified
  -> Maybe LinkableType
  -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface
  -> m ([FileDiagnostic], Maybe HiFileResult)
loadInterface :: HscEnv
-> ModSummary
-> SourceModified
-> Maybe LinkableType
-> (Maybe LinkableType -> m (IdeResult HiFileResult))
-> m (IdeResult HiFileResult)
loadInterface HscEnv
session ModSummary
ms SourceModified
sourceMod Maybe LinkableType
linkableNeeded Maybe LinkableType -> m (IdeResult HiFileResult)
regen = do
    let sessionWithMsDynFlags :: HscEnv
sessionWithMsDynFlags = DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
session
    (RecompileRequired, Maybe ModIface)
res <- 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
forall a. Maybe a
Nothing
    case (RecompileRequired, Maybe ModIface)
res of
          (RecompileRequired
UpToDate, Just ModIface
iface)
            -- If the module used TH splices when it was last
            -- compiled, then the recompilation check is not
            -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481)
            -- and we must ignore
            -- it.  However, if the module is stable (none of
            -- the modules it depends on, directly or
            -- indirectly, changed), then we *can* skip
            -- recompilation. This is why the SourceModified
            -- type contains SourceUnmodifiedAndStable, and
            -- it's pretty important: otherwise ghc --make
            -- would always recompile TH modules, even if
            -- nothing at all has changed. Stability is just
            -- the same check that make is doing for us in
            -- one-shot mode.
            | Bool -> Bool
not (ModIface -> Bool
forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th ModIface
iface) Bool -> Bool -> Bool
|| SourceModified
SourceUnmodifiedAndStable SourceModified -> SourceModified -> Bool
forall a. Eq a => a -> a -> Bool
== SourceModified
sourceMod
            -> do
             Maybe Linkable
linkable <- case Maybe LinkableType
linkableNeeded of
               Just LinkableType
ObjectLinkable -> 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
$ Module -> ModLocation -> IO (Maybe Linkable)
findObjectLinkableMaybe (ModSummary -> Module
ms_mod ModSummary
ms) (ModSummary -> ModLocation
ms_location ModSummary
ms)
               Maybe LinkableType
_ -> Maybe Linkable -> m (Maybe Linkable)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Linkable
forall a. Maybe a
Nothing

             -- We don't need to regenerate if the object is up do date, or we don't need one
             let objUpToDate :: Bool
objUpToDate = Maybe LinkableType -> Bool
forall a. Maybe a -> Bool
isNothing Maybe LinkableType
linkableNeeded Bool -> Bool -> Bool
|| case Maybe Linkable
linkable of
                   Maybe Linkable
Nothing                -> Bool
False
                   Just (LM UTCTime
obj_time Module
_ [Unlinked]
_) -> UTCTime
obj_time UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> ModSummary -> UTCTime
ms_hs_date ModSummary
ms
             if Bool
objUpToDate
             then 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
linkable
               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 -> HiFileResult
mkHiFileResult ModSummary
ms HomeModInfo
hmi)
             else Maybe LinkableType -> m (IdeResult HiFileResult)
regen Maybe LinkableType
linkableNeeded
          (RecompileRequired
_reason, Maybe ModIface
_) -> 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 -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms
                 FilePath -> FilePath -> m ()
setTag FilePath
"Reason" (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> FilePath
showReason RecompileRequired
_reason
                 Maybe LinkableType -> m (IdeResult HiFileResult)
regen Maybe LinkableType
linkableNeeded

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
showGhc) [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