-- Copyright (c) 2019 The DAML Authors. All rights reserved.

-- SPDX-License-Identifier: Apache-2.0


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
#include "ghc-api-version.h"

-- | 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
  , writeHieFile
  , writeHiFile
  , getModSummaryFromImports
  , loadHieFile
  , loadInterface
  , loadModulesHome
  , setupFinderCache
  , getDocsBatch
  , lookupName
  ) where

import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Preprocessor
import Development.IDE.Core.Shake
import Development.IDE.GHC.Error
import Development.IDE.GHC.Warnings
import Development.IDE.Types.Diagnostics
import Development.IDE.GHC.Orphans()
import Development.IDE.GHC.Util
import Development.IDE.Types.Options
import Development.IDE.Types.Location

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

import LoadIface (loadModuleInterface)
import DriverPhases
import HscTypes
import DriverPipeline hiding (unP)

import qualified Parser
import           Lexer
#if MIN_GHC_API_VERSION(8,10,0)
import Control.DeepSeq (force, rnf)
#else
import Control.DeepSeq (rnf)
import ErrUtils
#endif

import           Finder
import           Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile)
import qualified Development.IDE.GHC.Compat     as GHC
import qualified Development.IDE.GHC.Compat     as Compat
import           GhcMonad
import           GhcPlugins                     as GHC hiding (fst3, (<>))
import           HscMain                        (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive)
import           MkIface
import           StringBuffer                   as SB
import           TcRnMonad
import           TcIface                        (typecheckIface)
import           TidyPgm
import           Hooks
import           TcSplice

import Control.Exception.Safe
import Control.Lens hiding (List)
import Control.Monad.Extra
import Control.Monad.Except
import Control.Monad.Trans.Except
import Data.Bifunctor                           (first, second)
import qualified Data.ByteString as BS
import qualified Data.Text as T
import           Data.IORef
import           Data.List.Extra
import           Data.Maybe
import qualified Data.Map.Strict                          as Map
import           System.FilePath
import           System.Directory
import System.IO.Extra ( fixIO, newTempFileWithin )
import Control.Exception (evaluate)
import TcEnv (tcLookup)
import qualified Data.DList as DL
import Data.Time (UTCTime, getCurrentTime)
import Bag
import Linker (unload)
import qualified GHC.LanguageExtensions as LangExt
import PrelNames
import HeaderInfo
import Maybes (orElse)

-- | 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
FilePath
[FilePath]
[Text]
Maybe FilePath
CheckParents
Action IdeGhcSession
ShakeOptions
IdePkgLocationOptions
IdeOTMemoryProfiling
IdeTesting
IdeDefer
IdeReportProgress
OptHaddockParse
ParsedSource -> IdePreprocessedSource
DynFlags -> DynFlags
optShakeOptions :: IdeOptions -> ShakeOptions
optCustomDynFlags :: IdeOptions -> DynFlags -> DynFlags
optHaddockParse :: IdeOptions -> OptHaddockParse
optCheckParents :: IdeOptions -> CheckParents
optCheckProject :: IdeOptions -> Bool
optDefer :: IdeOptions -> IdeDefer
optKeywords :: IdeOptions -> [Text]
optNewColonConvention :: IdeOptions -> Bool
optLanguageSyntax :: IdeOptions -> FilePath
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
optShakeOptions :: ShakeOptions
optCustomDynFlags :: DynFlags -> DynFlags
optHaddockParse :: OptHaddockParse
optCheckParents :: CheckParents
optCheckProject :: Bool
optDefer :: IdeDefer
optKeywords :: [Text]
optNewColonConvention :: Bool
optLanguageSyntax :: FilePath
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
    -> InstalledUnitId
    -> IO (Either [FileDiagnostic] [InstalledUnitId])
computePackageDeps :: HscEnv
-> InstalledUnitId
-> IO (Either [FileDiagnostic] [InstalledUnitId])
computePackageDeps HscEnv
env InstalledUnitId
pkg = do
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
    case DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage DynFlags
dflags InstalledUnitId
pkg of
        Maybe PackageConfig
Nothing -> Either [FileDiagnostic] [InstalledUnitId]
-> IO (Either [FileDiagnostic] [InstalledUnitId])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] [InstalledUnitId]
 -> IO (Either [FileDiagnostic] [InstalledUnitId]))
-> Either [FileDiagnostic] [InstalledUnitId]
-> IO (Either [FileDiagnostic] [InstalledUnitId])
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Either [FileDiagnostic] [InstalledUnitId]
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]
++ InstalledUnitId -> FilePath
forall a. Show a => a -> FilePath
show InstalledUnitId
pkg]
        Just PackageConfig
pkgInfo -> Either [FileDiagnostic] [InstalledUnitId]
-> IO (Either [FileDiagnostic] [InstalledUnitId])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] [InstalledUnitId]
 -> IO (Either [FileDiagnostic] [InstalledUnitId]))
-> Either [FileDiagnostic] [InstalledUnitId]
-> IO (Either [FileDiagnostic] [InstalledUnitId])
forall a b. (a -> b) -> a -> b
$ [InstalledUnitId] -> Either [FileDiagnostic] [InstalledUnitId]
forall a b. b -> Either a b
Right ([InstalledUnitId] -> Either [FileDiagnostic] [InstalledUnitId])
-> [InstalledUnitId] -> Either [FileDiagnostic] [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ PackageConfig -> [InstalledUnitId]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
depends PackageConfig
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
    (Either [FileDiagnostic] (IdeResult TcModuleResult)
 -> IdeResult TcModuleResult)
-> IO (Either [FileDiagnostic] (IdeResult TcModuleResult))
-> IO (IdeResult TcModuleResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FileDiagnostic] -> IdeResult TcModuleResult)
-> (IdeResult TcModuleResult -> IdeResult TcModuleResult)
-> Either [FileDiagnostic] (IdeResult TcModuleResult)
-> IdeResult TcModuleResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (,Maybe TcModuleResult
forall a. Maybe a
Nothing) IdeResult TcModuleResult -> IdeResult TcModuleResult
forall a. a -> a
id) (IO (Either [FileDiagnostic] (IdeResult TcModuleResult))
 -> IO (IdeResult TcModuleResult))
-> IO (Either [FileDiagnostic] (IdeResult TcModuleResult))
-> IO (IdeResult TcModuleResult)
forall a b. (a -> b) -> a -> b
$
      DynFlags
-> Text
-> IO (IdeResult TcModuleResult)
-> IO (Either [FileDiagnostic] (IdeResult TcModuleResult))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc) Text
"typecheck" (IO (IdeResult TcModuleResult)
 -> IO (Either [FileDiagnostic] (IdeResult TcModuleResult)))
-> IO (IdeResult TcModuleResult)
-> IO (Either [FileDiagnostic] (IdeResult TcModuleResult))
forall a b. (a -> b) -> a -> b
$ do

        let modSummary :: ModSummary
modSummary = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pm
            dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSummary

        ModSummary
modSummary' <- HscEnv -> ModSummary -> IO ModSummary
initPlugins HscEnv
hsc ModSummary
modSummary
        ([(WarnReason, FileDiagnostic)]
warnings, TcModuleResult
tcm) <- Text
-> ((ModSummary -> ModSummary) -> IO TcModuleResult)
-> IO ([(WarnReason, FileDiagnostic)], TcModuleResult)
forall a.
Text
-> ((ModSummary -> ModSummary) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"typecheck" (((ModSummary -> ModSummary) -> IO TcModuleResult)
 -> IO ([(WarnReason, FileDiagnostic)], TcModuleResult))
-> ((ModSummary -> ModSummary) -> IO TcModuleResult)
-> IO ([(WarnReason, FileDiagnostic)], TcModuleResult)
forall a b. (a -> b) -> a -> b
$ \ModSummary -> ModSummary
tweak ->
            HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult
tcRnModule HscEnv
hsc [Linkable]
keep_lbls (ParsedModule -> IO TcModuleResult)
-> ParsedModule -> IO TcModuleResult
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedModule
enableTopLevelWarnings
                                     (ParsedModule -> ParsedModule) -> ParsedModule -> ParsedModule
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedModule
demoteIfDefer ParsedModule
pm{pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary -> ModSummary
tweak ModSummary
modSummary'}
        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
        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 :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices)
captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices)
captureSplices DynFlags
dflags DynFlags -> 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 <- DynFlags -> IO a
k (DynFlags
dflags { hooks :: Hooks
hooks = IORef Splices -> Hooks -> Hooks
addSpliceHook IORef Splices
splice_ref (DynFlags -> Hooks
hooks DynFlags
dflags)})
  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 = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }

  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
$ DynFlags
-> (DynFlags -> IO (TcGblEnv, RenamedStuff))
-> IO ((TcGblEnv, RenamedStuff), Splices)
forall a. DynFlags -> (DynFlags -> IO a) -> IO (a, Splices)
captureSplices (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) ((DynFlags -> IO (TcGblEnv, RenamedStuff))
 -> IO ((TcGblEnv, RenamedStuff), Splices))
-> (DynFlags -> IO (TcGblEnv, RenamedStuff))
-> IO ((TcGblEnv, RenamedStuff), Splices)
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
             do  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags }
                 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 = HscEnv
session { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
      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_GHC_API_VERSION(8,10,0)
  ModIface
iface <- HscEnv -> SafeHaskellMode -> ModDetails -> TcGblEnv -> IO ModIface
mkIfaceTc HscEnv
session SafeHaskellMode
sf ModDetails
details TcGblEnv
tcGblEnv
#else
  (iface, _) <- mkIfaceTc session 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
HiFileResult 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 = HscEnv
session' { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
      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_GHC_API_VERSION(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
HiFileResult 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
    DynFlags
dflags <- IO DynFlags -> IO DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> IO DynFlags) -> IO DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
session (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSummary
    ModSummary -> IO ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
modSummary{ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags}

-- | 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
-> ((ModSummary -> ModSummary) -> IO ModGuts)
-> IO ([(WarnReason, FileDiagnostic)], ModGuts)
forall a.
Text
-> ((ModSummary -> ModSummary) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"compile" (((ModSummary -> ModSummary) -> IO ModGuts)
 -> IO ([(WarnReason, FileDiagnostic)], ModGuts))
-> ((ModSummary -> ModSummary) -> IO ModGuts)
-> IO ([(WarnReason, FileDiagnostic)], ModGuts)
forall a b. (a -> b) -> a -> b
$ \ModSummary -> ModSummary
tweak -> do
               let ms' :: ModSummary
ms' = ModSummary -> ModSummary
tweak ModSummary
ms
                   session' :: HscEnv
session' = HscEnv
session{ hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms'}
               ModGuts
desugar <- HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
session' ModSummary
ms' 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
-> ((ModSummary -> ModSummary) -> IO FilePath)
-> IO ([(WarnReason, FileDiagnostic)], FilePath)
forall a.
Text
-> ((ModSummary -> ModSummary) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"object" (((ModSummary -> ModSummary) -> IO FilePath)
 -> IO ([(WarnReason, FileDiagnostic)], FilePath))
-> ((ModSummary -> ModSummary) -> IO FilePath)
-> IO ([(WarnReason, FileDiagnostic)], FilePath)
forall a b. (a -> b) -> a -> b
$ \ModSummary -> ModSummary
_tweak -> do
                      let summary' :: ModSummary
summary' = ModSummary -> ModSummary
_tweak ModSummary
summary
                          session' :: HscEnv
session' = HscEnv
session { hsc_dflags :: DynFlags
hsc_dflags = (ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary') { outputFile :: Maybe FilePath
outputFile = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dot_o }}
                      (FilePath
outputFilename, Maybe FilePath
_mStub, [(ForeignSrcLang, FilePath)]
_foreign_files) <- HscEnv
-> CgGuts
-> ModLocation
-> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
hscGenHardCode HscEnv
session' CgGuts
guts
#if MIN_GHC_API_VERSION(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
-> ((ModSummary -> ModSummary)
    -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
-> IO
     ([(WarnReason, FileDiagnostic)],
      (Maybe FilePath, CompiledByteCode, [SptEntry]))
forall a.
Text
-> ((ModSummary -> ModSummary) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
"bytecode" (((ModSummary -> ModSummary)
  -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
 -> IO
      ([(WarnReason, FileDiagnostic)],
       (Maybe FilePath, CompiledByteCode, [SptEntry])))
-> ((ModSummary -> ModSummary)
    -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]))
-> IO
     ([(WarnReason, FileDiagnostic)],
      (Maybe FilePath, CompiledByteCode, [SptEntry]))
forall a b. (a -> b) -> a -> b
$ \ModSummary -> ModSummary
_tweak -> do
                      let summary' :: ModSummary
summary' = ModSummary -> ModSummary
_tweak ModSummary
summary
                          session :: HscEnv
session = HscEnv
hscEnv { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary' }
                      HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
session CgGuts
guts
#if MIN_GHC_API_VERSION(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)

enableTopLevelWarnings :: ParsedModule -> ParsedModule
enableTopLevelWarnings :: ParsedModule -> ParsedModule
enableTopLevelWarnings =
  ((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 -> WarningFlag -> DynFlags
`wopt_set` WarningFlag
Opt_WarnMissingPatternSynonymSignatures) (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (DynFlags -> WarningFlag -> DynFlags
`wopt_set` WarningFlag
Opt_WarnMissingSignatures))
  -- the line below would show also warnings for let bindings without signature

  -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))


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_GHC_API_VERSION(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
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
    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
`unionBags` Bag (LHsBind GhcTc)
real_binds) (TcModuleResult
-> (HsGroup GhcRn, [LImportDecl GhcRn],
    Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString)
tmrRenamed TcModuleResult
tcm)
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv

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
        ]

writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
writeHieFile :: HscEnv
-> ModSummary
-> Avails
-> HieASTs Type
-> ByteString
-> IO [FileDiagnostic]
writeHieFile HscEnv
hscEnv ModSummary
mod_summary 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
  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 generation" (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 ->
      DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile DynFlags
dflags 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
    ]

-- | Initialise the finder cache, dependencies should be topologically

-- sorted.

setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv
setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv
setupFinderCache [ModSummary]
mss HscEnv
session = do

    -- Make modules available for others that import them,

    -- by putting them in the finder cache.

    let ims :: [InstalledModule]
ims  = (ModSummary -> InstalledModule)
-> [ModSummary] -> [InstalledModule]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId -> ModuleName -> InstalledModule
InstalledModule (DynFlags -> InstalledUnitId
thisInstalledUnitId (DynFlags -> InstalledUnitId) -> DynFlags -> InstalledUnitId
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
session) (ModuleName -> InstalledModule)
-> (ModSummary -> ModuleName) -> ModSummary -> InstalledModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) [ModSummary]
mss
        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]
mss [InstalledModule]
ims
    -- set the target and module graph in the session

        graph :: ModuleGraph
graph = [ModSummary] -> ModuleGraph
mkModuleGraph [ModSummary]
mss

    -- We have to create a new IORef here instead of modifying the existing IORef as

    -- it is shared between concurrent compilations.

    FinderCache
prevFinderCache <- IORef FinderCache -> IO FinderCache
forall a. IORef a -> IO a
readIORef (IORef FinderCache -> IO FinderCache)
-> IORef FinderCache -> IO FinderCache
forall a b. (a -> b) -> a -> b
$ HscEnv -> IORef FinderCache
hsc_FC HscEnv
session
    let newFinderCache :: FinderCache
newFinderCache =
            (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
GHC.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
    IORef FinderCache
newFinderCacheVar <- 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
newFinderCache

    HscEnv -> IO HscEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
session { hsc_FC :: IORef FinderCache
hsc_FC = IORef FinderCache
newFinderCacheVar, hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
graph }


-- | 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 =
    HscEnv
e { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
e) [(HomeModInfo -> ModuleName
mod_name HomeModInfo
x, HomeModInfo
x) | HomeModInfo
x <- [HomeModInfo]
mod_infos]
      , 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

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 SB.StringBuffer
  -> ExceptT [FileDiagnostic] IO (ModSummary,[LImportDecl GhcPs])
getModSummaryFromImports :: HscEnv
-> FilePath
-> UTCTime
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO (ModSummary, [LImportDecl GhcPs])
getModSummaryFromImports HscEnv
env FilePath
fp UTCTime
modTime Maybe StringBuffer
contents = do
    (StringBuffer
contents, DynFlags
dflags) <- HscEnv
-> FilePath
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO (StringBuffer, 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
`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 (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)
                                         , 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)

        allImps :: [LImportDecl GhcPs]
allImps = [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
$ DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation DynFlags
dflags ModuleName
mod FilePath
fp

    let modl :: Module
modl = UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
dflags) 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
        summary :: ModSummary
summary =
            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_GHC_API_VERSION(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
                }
    (ModSummary, [LImportDecl GhcPs])
-> ExceptT [FileDiagnostic] IO (ModSummary, [LImportDecl GhcPs])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary
summary, [LImportDecl GhcPs]
allImps)

-- | Parse only the module header

parseHeader
       :: Monad m
       => DynFlags -- ^ flags to use

       -> FilePath  -- ^ the filename (for source locations)

       -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))
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
mkFastString FilePath
filename) Int
1 Int
1
   case P ParsedSource -> PState -> ParseResult ParsedSource
forall a. P a -> PState -> ParseResult a
unP P ParsedSource
Parser.parseHeader (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
contents RealSrcLoc
loc) of
#if MIN_GHC_API_VERSION(8,10,0)
     PFailed PState
pst ->
        [FileDiagnostic]
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([FileDiagnostic]
 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource))
-> [FileDiagnostic]
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedSource)
forall a b. (a -> b) -> a -> b
$ Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags (Bag ErrMsg -> [FileDiagnostic]) -> Bag ErrMsg -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> Bag ErrMsg
getErrorMessages PState
pst DynFlags
dflags
#else
     PFailed _ locErr msgErr ->
        throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
#endif
     POk PState
pst ParsedSource
rdr_module -> do
        let (Bag ErrMsg
warns, Bag ErrMsg
errs) = PState -> DynFlags -> (Bag ErrMsg, Bag ErrMsg)
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 (Bag ErrMsg -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag ErrMsg
errs) (ExceptT [FileDiagnostic] m () -> ExceptT [FileDiagnostic] m ())
-> ExceptT [FileDiagnostic] m () -> ExceptT [FileDiagnostic] m ()
forall a b. (a -> b) -> a -> b
$
            [FileDiagnostic] -> ExceptT [FileDiagnostic] m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([FileDiagnostic] -> ExceptT [FileDiagnostic] m ())
-> [FileDiagnostic] -> ExceptT [FileDiagnostic] m ()
forall a b. (a -> b) -> a -> b
$ Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags Bag ErrMsg
errs

        let warnings :: [FileDiagnostic]
warnings = Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags Bag ErrMsg
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
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
Parser.parseModule (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
contents RealSrcLoc
loc) of
#if MIN_GHC_API_VERSION(8,10,0)
     PFailed PState
pst -> [FileDiagnostic]
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([FileDiagnostic]
 -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule))
-> [FileDiagnostic]
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
forall a b. (a -> b) -> a -> b
$ Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags (Bag ErrMsg -> [FileDiagnostic]) -> Bag ErrMsg -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> Bag ErrMsg
getErrorMessages PState
pst DynFlags
dflags
#else
     PFailed _ locErr msgErr ->
      throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
#endif
     POk PState
pst ParsedSource
rdr_module ->
         let hpm_annotations :: ApiAnns
hpm_annotations =
               (([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall a b. (a -> b) -> a -> b
$ PState -> [(ApiAnnKey, [SrcSpan])]
annotations PState
pst,
                 [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((SrcSpan
noSrcSpan,PState -> [Located AnnotationComment]
comment_q PState
pst)
                                  (SrcSpan, [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> [(SrcSpan, [Located AnnotationComment])]
forall a. a -> [a] -> [a]
:PState -> [(SrcSpan, [Located AnnotationComment])]
annotations_comments PState
pst))
             (Bag ErrMsg
warns, Bag ErrMsg
errs) = PState -> DynFlags -> (Bag ErrMsg, Bag ErrMsg)
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 (Bag ErrMsg -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag ErrMsg
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 -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags Bag ErrMsg
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
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 =
                     ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule
ParsedModule {
                         pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
ms
                       , pm_parsed_source :: ParsedSource
pm_parsed_source = ParsedSource
parsed'
                       , pm_extra_src_files :: [FilePath]
pm_extra_src_files = [FilePath]
srcs2
                       , pm_annotations :: ApiAnns
pm_annotations = ApiAnns
hpm_annotations
                      }
                   warnings :: [FileDiagnostic]
warnings = Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
"parser" DynFlags
dflags Bag ErrMsg
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 => 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
    (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
session 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
session 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
HiFileResult ModSummary
ms HomeModInfo
hmi)
             else Maybe LinkableType -> m (IdeResult HiFileResult)
regen Maybe LinkableType
linkableNeeded
          (RecompileRequired
_reason, Maybe ModIface
_) -> Maybe LinkableType -> m (IdeResult HiFileResult)
regen Maybe LinkableType
linkableNeeded

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, Map.Map Int HsDocString)]
getDocsBatch :: HscEnv
-> Module
-> [Name]
-> IO [Either FilePath (Maybe HsDocString, Map Int HsDocString)]
getDocsBatch HscEnv
hsc_env Module
_mod [Name]
_names = do
    ((Bag ErrMsg
_warns,Bag ErrMsg
errs), Maybe
  [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
res) <- HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
-> IO
     ((Bag ErrMsg, Bag ErrMsg),
      Maybe
        [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)])
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO ((Bag ErrMsg, Bag ErrMsg), Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
_mod RealSrcSpan
fakeSpan (TcM
   [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
 -> IO
      ((Bag ErrMsg, Bag ErrMsg),
       Maybe
         [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]))
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
-> IO
     ((Bag ErrMsg, Bag ErrMsg),
      Maybe
        [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)])
forall a b. (a -> b) -> a -> b
$ [Name]
-> (Name
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)))
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, Map Int 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, Map Int HsDocString)))
 -> TcM
      [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)])
-> (Name
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)))
-> TcM
     [Either GetDocsFailure (Maybe HsDocString, Map Int 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, Map Int HsDocString)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return (GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
forall a b. a -> Either a b
Left (GetDocsFailure
 -> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
-> GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, Map Int 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 k a. Map k a -> Bool
Map.null Map Name (Map Int HsDocString)
amap
               then Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, Map Int 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, Map Int HsDocString)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe HsDocString, Map Int HsDocString)
-> Either GetDocsFailure (Maybe HsDocString, Map Int 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
                                , 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 k a. Map k a
Map.empty Name
name Map Name (Map Int HsDocString)
amap))
    case Maybe
  [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
res of
        Just [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
x -> [Either FilePath (Maybe HsDocString, Map Int HsDocString)]
-> IO [Either FilePath (Maybe HsDocString, Map Int HsDocString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either FilePath (Maybe HsDocString, Map Int HsDocString)]
 -> IO [Either FilePath (Maybe HsDocString, Map Int HsDocString)])
-> [Either FilePath (Maybe HsDocString, Map Int HsDocString)]
-> IO [Either FilePath (Maybe HsDocString, Map Int HsDocString)]
forall a b. (a -> b) -> a -> b
$ (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
 -> Either FilePath (Maybe HsDocString, Map Int HsDocString))
-> [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
-> [Either FilePath (Maybe HsDocString, Map Int HsDocString)]
forall a b. (a -> b) -> [a] -> [b]
map ((GetDocsFailure -> FilePath)
-> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
-> Either FilePath (Maybe HsDocString, Map Int HsDocString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first GetDocsFailure -> FilePath
forall a. Outputable a => a -> FilePath
prettyPrint) [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
x
        Maybe
  [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
Nothing -> Bag ErrMsg
-> IO [Either FilePath (Maybe HsDocString, Map Int HsDocString)]
forall a. Bag ErrMsg -> IO a
throwErrors Bag ErrMsg
errs
  where
    throwErrors :: Bag ErrMsg -> IO a
throwErrors = IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> (Bag ErrMsg -> IO a) -> Bag ErrMsg -> 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)
-> (Bag ErrMsg -> SourceError) -> Bag ErrMsg -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag ErrMsg -> 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
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
    ((Bag ErrMsg, Bag ErrMsg)
_messages, Maybe TyThing
res) <- HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM TyThing
-> IO ((Bag ErrMsg, Bag ErrMsg), Maybe TyThing)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO ((Bag ErrMsg, Bag ErrMsg), Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
mod RealSrcSpan
fakeSpan (TcM TyThing -> IO ((Bag ErrMsg, Bag ErrMsg), Maybe TyThing))
-> TcM TyThing -> IO ((Bag ErrMsg, Bag ErrMsg), 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