mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
simplify things unnecessarily running in GhcM (#875)
* simplify things unnecessarily running in GhcM * untick catchSrcErrors * set useUnicode
This commit is contained in:
parent
e2ee58f338
commit
d76fbf9a5c
@ -175,7 +175,6 @@ library
|
||||
Development.IDE.GHC.CPP
|
||||
Development.IDE.GHC.Orphans
|
||||
Development.IDE.GHC.Warnings
|
||||
Development.IDE.GHC.WithDynFlags
|
||||
Development.IDE.Import.FindImports
|
||||
Development.IDE.LSP.Notifications
|
||||
Development.IDE.Spans.Documentation
|
||||
|
@ -371,7 +371,7 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv
|
||||
emptyHscEnv nc libDir = do
|
||||
env <- runGhc (Just libDir) getSession
|
||||
initDynLinker env
|
||||
pure $ setNameCache nc env
|
||||
pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } }
|
||||
|
||||
data TargetDetails = TargetDetails
|
||||
{
|
||||
|
@ -89,7 +89,6 @@ import System.FilePath
|
||||
import System.Directory
|
||||
import System.IO.Extra
|
||||
import Control.Exception (evaluate)
|
||||
import Exception (ExceptionMonad)
|
||||
import TcEnv (tcLookup)
|
||||
import Data.Time (UTCTime, getCurrentTime)
|
||||
import Linker (unload)
|
||||
@ -105,7 +104,7 @@ parseModule
|
||||
-> IO (IdeResult (StringBuffer, ParsedModule))
|
||||
parseModule IdeOptions{..} env comp_pkgs filename modTime mbContents =
|
||||
fmap (either (, Nothing) id) $
|
||||
evalGhcEnv env $ runExceptT $ do
|
||||
runExceptT $ do
|
||||
(contents, dflags) <- preprocessor env filename mbContents
|
||||
(diag, modu) <- parseFileContents env optPreprocessor dflags comp_pkgs filename modTime contents
|
||||
return (diag, Just (contents, modu))
|
||||
@ -127,20 +126,19 @@ typecheckModule :: IdeDefer
|
||||
-> HscEnv
|
||||
-> Maybe [Linkable] -- ^ linkables not to unload, if Nothing don't unload anything
|
||||
-> ParsedModule
|
||||
-> IO (IdeResult (HscEnv, TcModuleResult))
|
||||
-> IO (IdeResult TcModuleResult)
|
||||
typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
|
||||
fmap (\(hsc, res) -> case res of Left d -> (d,Nothing); Right (d,res) -> (d,fmap (hsc,) res)) $
|
||||
runGhcEnv hsc $
|
||||
catchSrcErrors "typecheck" $ do
|
||||
fmap (either (,Nothing) id) $
|
||||
catchSrcErrors (hsc_dflags hsc) "typecheck" $ do
|
||||
|
||||
let modSummary = pm_mod_summary pm
|
||||
dflags = ms_hspp_opts modSummary
|
||||
|
||||
modSummary' <- initPlugins modSummary
|
||||
modSummary' <- initPlugins hsc modSummary
|
||||
(warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
|
||||
tcRnModule keep_lbls $ enableTopLevelWarnings
|
||||
$ enableUnnecessaryAndDeprecationWarnings
|
||||
$ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
|
||||
tcRnModule hsc keep_lbls $ enableTopLevelWarnings
|
||||
$ enableUnnecessaryAndDeprecationWarnings
|
||||
$ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
|
||||
let errorPipeline = unDefer . hideDiag dflags . tagDiag
|
||||
diags = map errorPipeline warnings
|
||||
deferedError = any fst diags
|
||||
@ -148,18 +146,17 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
|
||||
where
|
||||
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
|
||||
|
||||
tcRnModule :: GhcMonad m => Maybe [Linkable] -> ParsedModule -> m TcModuleResult
|
||||
tcRnModule keep_lbls pmod = do
|
||||
tcRnModule :: HscEnv -> Maybe [Linkable] -> ParsedModule -> IO TcModuleResult
|
||||
tcRnModule hsc_env keep_lbls pmod = do
|
||||
let ms = pm_mod_summary pmod
|
||||
hsc_env <- getSession
|
||||
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
|
||||
(tc_gbl_env, mrn_info)
|
||||
<- liftIO $ do
|
||||
whenJust keep_lbls $ unload hsc_env_tmp
|
||||
hscTypecheckRename hsc_env_tmp ms $
|
||||
HsParsedModule { hpm_module = parsedSource pmod,
|
||||
hpm_src_files = pm_extra_src_files pmod,
|
||||
hpm_annotations = pm_annotations pmod }
|
||||
hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
|
||||
|
||||
whenJust keep_lbls $ unload hsc_env_tmp
|
||||
(tc_gbl_env, mrn_info) <-
|
||||
hscTypecheckRename hsc_env_tmp ms $
|
||||
HsParsedModule { hpm_module = parsedSource pmod,
|
||||
hpm_src_files = pm_extra_src_files pmod,
|
||||
hpm_annotations = pm_annotations pmod }
|
||||
let rn_info = case mrn_info of
|
||||
Just x -> x
|
||||
Nothing -> error "no renamed info tcRnModule"
|
||||
@ -215,9 +212,8 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
|
||||
. (("Error during " ++ T.unpack source) ++) . show @SomeException
|
||||
]
|
||||
|
||||
initPlugins :: GhcMonad m => ModSummary -> m ModSummary
|
||||
initPlugins modSummary = do
|
||||
session <- getSession
|
||||
initPlugins :: HscEnv -> ModSummary -> IO ModSummary
|
||||
initPlugins session modSummary = do
|
||||
dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary
|
||||
return modSummary{ms_hspp_opts = dflags}
|
||||
|
||||
@ -235,40 +231,37 @@ compileModule
|
||||
-> ModSummary
|
||||
-> TcGblEnv
|
||||
-> IO (IdeResult ModGuts)
|
||||
compileModule (RunSimplifier simplify) packageState ms tcg =
|
||||
compileModule (RunSimplifier simplify) session ms tcg =
|
||||
fmap (either (, Nothing) (second Just)) $
|
||||
evalGhcEnv packageState $
|
||||
catchSrcErrors "compile" $ do
|
||||
session <- getSession
|
||||
(warnings,desugar) <- withWarnings "compile" $ \tweak -> do
|
||||
catchSrcErrors (hsc_dflags session) "compile" $ do
|
||||
(warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do
|
||||
let ms' = tweak ms
|
||||
liftIO $ hscDesugar session{ hsc_dflags = ms_hspp_opts ms'} ms' tcg
|
||||
desugared_guts <-
|
||||
if simplify
|
||||
then do
|
||||
plugins <- liftIO $ readIORef (tcg_th_coreplugins tcg)
|
||||
liftIO $ hscSimplify session plugins desugar
|
||||
else pure desugar
|
||||
session' = session{ hsc_dflags = ms_hspp_opts ms'}
|
||||
desugar <- hscDesugar session' ms' tcg
|
||||
if simplify
|
||||
then do
|
||||
plugins <- readIORef (tcg_th_coreplugins tcg)
|
||||
hscSimplify session' plugins desugar
|
||||
else pure desugar
|
||||
return (map snd warnings, desugared_guts)
|
||||
|
||||
generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
|
||||
generateObjectCode hscEnv summary guts = do
|
||||
generateObjectCode session summary guts = do
|
||||
fmap (either (, Nothing) (second Just)) $
|
||||
evalGhcEnv hscEnv $
|
||||
catchSrcErrors "object" $ do
|
||||
session <- getSession
|
||||
catchSrcErrors (hsc_dflags session) "object" $ do
|
||||
let dot_o = ml_obj_file (ms_location summary)
|
||||
mod = ms_mod summary
|
||||
session' = session { hsc_dflags = (hsc_dflags session) { outputFile = Just dot_o }}
|
||||
fp = replaceExtension dot_o "s"
|
||||
liftIO $ createDirectoryIfMissing True (takeDirectory fp)
|
||||
createDirectoryIfMissing True (takeDirectory fp)
|
||||
(warnings, dot_o_fp) <-
|
||||
withWarnings "object" $ \_tweak -> liftIO $ do
|
||||
withWarnings "object" $ \_tweak -> do
|
||||
let summary' = _tweak summary
|
||||
session' = session { hsc_dflags = (ms_hspp_opts summary') { outputFile = Just dot_o }}
|
||||
(outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
(ms_location summary)
|
||||
(ms_location summary')
|
||||
#else
|
||||
(_tweak summary)
|
||||
summary'
|
||||
#endif
|
||||
fp
|
||||
compileFile session' StopLn (outputFilename, Just (As False))
|
||||
@ -282,16 +275,16 @@ generateObjectCode hscEnv summary guts = do
|
||||
generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
|
||||
generateByteCode hscEnv summary guts = do
|
||||
fmap (either (, Nothing) (second Just)) $
|
||||
evalGhcEnv hscEnv $
|
||||
catchSrcErrors "bytecode" $ do
|
||||
session <- getSession
|
||||
catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do
|
||||
(warnings, (_, bytecode, sptEntries)) <-
|
||||
withWarnings "bytecode" $ \_tweak -> liftIO $
|
||||
withWarnings "bytecode" $ \_tweak -> do
|
||||
let summary' = _tweak summary
|
||||
session = hscEnv { hsc_dflags = ms_hspp_opts summary' }
|
||||
hscInteractive session guts
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
(ms_location summary)
|
||||
(ms_location summary')
|
||||
#else
|
||||
(_tweak summary)
|
||||
summary'
|
||||
#endif
|
||||
let unlinked = BCOs bytecode sptEntries
|
||||
time <- liftIO getCurrentTime
|
||||
@ -510,13 +503,12 @@ withBootSuffix _ = id
|
||||
|
||||
-- | Produce a module summary from a StringBuffer.
|
||||
getModSummaryFromBuffer
|
||||
:: GhcMonad m
|
||||
=> FilePath
|
||||
:: FilePath
|
||||
-> UTCTime
|
||||
-> DynFlags
|
||||
-> GHC.ParsedSource
|
||||
-> StringBuffer
|
||||
-> ExceptT [FileDiagnostic] m ModSummary
|
||||
-> ExceptT [FileDiagnostic] IO ModSummary
|
||||
getModSummaryFromBuffer fp modTime dflags parsed contents = do
|
||||
(modName, imports) <- liftEither $ getImportsParsed dflags parsed
|
||||
|
||||
@ -553,12 +545,11 @@ getModSummaryFromBuffer fp modTime dflags parsed contents = do
|
||||
-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
|
||||
-- Runs preprocessors as needed.
|
||||
getModSummaryFromImports
|
||||
:: (HasDynFlags m, ExceptionMonad m, MonadIO m)
|
||||
=> HscEnv
|
||||
:: HscEnv
|
||||
-> FilePath
|
||||
-> UTCTime
|
||||
-> Maybe SB.StringBuffer
|
||||
-> ExceptT [FileDiagnostic] m ModSummary
|
||||
-> ExceptT [FileDiagnostic] IO ModSummary
|
||||
getModSummaryFromImports env fp modTime contents = do
|
||||
(contents, dflags) <- preprocessor env fp contents
|
||||
(srcImports, textualImports, L _ moduleName) <-
|
||||
@ -595,7 +586,7 @@ getModSummaryFromImports env fp modTime contents = do
|
||||
|
||||
-- | Parse only the module header
|
||||
parseHeader
|
||||
:: GhcMonad m
|
||||
:: Monad m
|
||||
=> DynFlags -- ^ flags to use
|
||||
-> FilePath -- ^ the filename (for source locations)
|
||||
-> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
|
||||
@ -630,15 +621,14 @@ parseHeader dflags filename contents = do
|
||||
-- | Given a buffer, flags, and file path, produce a
|
||||
-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
|
||||
parseFileContents
|
||||
:: GhcMonad m
|
||||
=> HscEnv
|
||||
:: HscEnv
|
||||
-> (GHC.ParsedSource -> IdePreprocessedSource)
|
||||
-> DynFlags -- ^ flags to use
|
||||
-> [PackageName] -- ^ The package imports to ignore
|
||||
-> FilePath -- ^ the filename (for source locations)
|
||||
-> UTCTime -- ^ the modification timestamp
|
||||
-> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
|
||||
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
|
||||
-> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
|
||||
parseFileContents env customPreprocessor dflags comp_pkgs filename modTime contents = do
|
||||
let loc = mkRealSrcLoc (mkFastString filename) 1 1
|
||||
case unP Parser.parseModule (mkPState dflags contents loc) of
|
||||
@ -756,12 +746,12 @@ mkDetailsFromIface session iface linkable = do
|
||||
-- | 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 :: GhcMonad m
|
||||
=> Module -- ^ a moudle where the names are in scope
|
||||
-> [Name]
|
||||
-> m [Either String (Maybe HsDocString, Map.Map Int HsDocString)]
|
||||
getDocsBatch _mod _names =
|
||||
withSession $ \hsc_env -> liftIO $ do
|
||||
getDocsBatch
|
||||
:: HscEnv
|
||||
-> Module -- ^ a moudle where the names are in scope
|
||||
-> [Name]
|
||||
-> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)]
|
||||
getDocsBatch hsc_env _mod _names = do
|
||||
((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->
|
||||
case nameModule_maybe name of
|
||||
Nothing -> return (Left $ NameHasNoModule name)
|
||||
@ -791,11 +781,11 @@ fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<ghcide>") 1 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 :: GhcMonad m
|
||||
=> Module -- ^ A module where the Names are in scope
|
||||
lookupName :: HscEnv
|
||||
-> Module -- ^ A module where the Names are in scope
|
||||
-> Name
|
||||
-> m (Maybe TyThing)
|
||||
lookupName mod name = withSession $ \hsc_env -> liftIO $ do
|
||||
-> IO (Maybe TyThing)
|
||||
lookupName hsc_env mod name = do
|
||||
(_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do
|
||||
tcthing <- tcLookup name
|
||||
case tcthing of
|
||||
|
@ -31,18 +31,17 @@ import qualified Data.Text as T
|
||||
import Outputable (showSDoc)
|
||||
import Control.DeepSeq (NFData(rnf))
|
||||
import Control.Exception (evaluate)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Exception (ExceptionMonad)
|
||||
import HscTypes (HscEnv(hsc_dflags))
|
||||
|
||||
|
||||
-- | Given a file and some contents, apply any necessary preprocessors,
|
||||
-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
|
||||
preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
|
||||
preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
|
||||
preprocessor env filename mbContents = do
|
||||
-- Perform unlit
|
||||
(isOnDisk, contents) <-
|
||||
if isLiterate filename then do
|
||||
dflags <- getDynFlags
|
||||
let dflags = hsc_dflags env
|
||||
newcontent <- liftIO $ runLhs dflags filename mbContents
|
||||
return (False, newcontent)
|
||||
else do
|
||||
@ -58,7 +57,6 @@ preprocessor env filename mbContents = do
|
||||
else do
|
||||
cppLogs <- liftIO $ newIORef []
|
||||
contents <- ExceptT
|
||||
$ liftIO
|
||||
$ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename
|
||||
$ if isOnDisk then Nothing else Just contents))
|
||||
`catch`
|
||||
@ -133,21 +131,20 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
|
||||
|
||||
-- | This reads the pragma information directly from the provided buffer.
|
||||
parsePragmasIntoDynFlags
|
||||
:: (ExceptionMonad m, HasDynFlags m, MonadIO m)
|
||||
=> HscEnv
|
||||
:: HscEnv
|
||||
-> FilePath
|
||||
-> SB.StringBuffer
|
||||
-> m (Either [FileDiagnostic] DynFlags)
|
||||
parsePragmasIntoDynFlags env fp contents = catchSrcErrors "pragmas" $ do
|
||||
dflags0 <- getDynFlags
|
||||
-> IO (Either [FileDiagnostic] DynFlags)
|
||||
parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do
|
||||
let opts = Hdr.getOptions dflags0 contents fp
|
||||
|
||||
-- Force bits that might keep the dflags and stringBuffer alive unnecessarily
|
||||
liftIO $ evaluate $ rnf opts
|
||||
evaluate $ rnf opts
|
||||
|
||||
(dflags, _, _) <- parseDynamicFilePragma dflags0 opts
|
||||
dflags' <- liftIO $ initializePlugins env dflags
|
||||
dflags' <- initializePlugins env dflags
|
||||
return $ disableWarningsAsErrors dflags'
|
||||
where dflags0 = hsc_dflags env
|
||||
|
||||
-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
|
||||
runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
||||
|
@ -49,7 +49,6 @@ import Development.IDE.Types.Diagnostics as Diag
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile)
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.GHC.WithDynFlags
|
||||
import Data.Either.Extra
|
||||
import qualified Development.IDE.Types.Logger as L
|
||||
import Data.Maybe
|
||||
@ -575,7 +574,7 @@ getDocMapRule =
|
||||
parsedDeps <- uses_ GetParsedModule tdeps
|
||||
#endif
|
||||
|
||||
dkMap <- liftIO $ evalGhcEnv hsc $ mkDocMap parsedDeps rf tc
|
||||
dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc
|
||||
return ([],Just dkMap)
|
||||
|
||||
-- Typechecks a module.
|
||||
@ -611,7 +610,7 @@ typeCheckRuleDefinition hsc pm = do
|
||||
|
||||
linkables_to_keep <- currentLinkables
|
||||
|
||||
addUsageDependencies $ fmap (second (fmap snd)) $ liftIO $
|
||||
addUsageDependencies $ liftIO $
|
||||
typecheckModule defer hsc (Just linkables_to_keep) pm
|
||||
where
|
||||
addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
|
||||
@ -746,7 +745,7 @@ getModSummaryRule = do
|
||||
let dflags = hsc_dflags session
|
||||
(modTime, mFileContent) <- getFileContents f
|
||||
let fp = fromNormalizedFilePath f
|
||||
modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
|
||||
modS <- liftIO $ runExceptT $
|
||||
getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)
|
||||
case modS of
|
||||
Right ms -> do
|
||||
|
@ -33,13 +33,11 @@ import Development.IDE.GHC.Orphans()
|
||||
import qualified FastString as FS
|
||||
import GHC
|
||||
import Bag
|
||||
import DynFlags
|
||||
import HscTypes
|
||||
import Panic
|
||||
import ErrUtils
|
||||
import SrcLoc
|
||||
import qualified Outputable as Out
|
||||
import Exception (ExceptionMonad)
|
||||
|
||||
|
||||
|
||||
@ -137,14 +135,14 @@ realSpan = \case
|
||||
UnhelpfulSpan _ -> Nothing
|
||||
|
||||
|
||||
-- | Run something in a Ghc monad and catch the errors (SourceErrors and
|
||||
-- compiler-internal exceptions like Panic or InstallationError).
|
||||
catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)
|
||||
catchSrcErrors fromWhere ghcM = do
|
||||
dflags <- getDynFlags
|
||||
handleGhcException (ghcExceptionToDiagnostics dflags) $
|
||||
handleSourceError (sourceErrorToDiagnostics dflags) $
|
||||
Right <$> ghcM
|
||||
-- | Catch the errors thrown by GHC (SourceErrors and
|
||||
-- compiler-internal exceptions like Panic or InstallationError), and turn them into
|
||||
-- diagnostics
|
||||
catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a)
|
||||
catchSrcErrors dflags fromWhere ghcM = do
|
||||
handleGhcException (ghcExceptionToDiagnostics dflags) $
|
||||
handleSourceError (sourceErrorToDiagnostics dflags) $
|
||||
Right <$> ghcM
|
||||
where
|
||||
ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
|
||||
sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages
|
||||
|
@ -10,7 +10,6 @@ module Development.IDE.GHC.Util(
|
||||
envImportPaths,
|
||||
modifyDynFlags,
|
||||
evalGhcEnv,
|
||||
runGhcEnv,
|
||||
deps,
|
||||
-- * GHC wrappers
|
||||
prettyPrint,
|
||||
|
@ -3,16 +3,13 @@
|
||||
|
||||
module Development.IDE.GHC.Warnings(withWarnings) where
|
||||
|
||||
import GhcMonad
|
||||
import ErrUtils
|
||||
import GhcPlugins as GHC hiding (Var)
|
||||
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Monad.Extra
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.GHC.Error
|
||||
|
||||
|
||||
@ -25,19 +22,13 @@ import Development.IDE.GHC.Error
|
||||
-- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640
|
||||
-- which basically says that log_action is taken from the ModSummary when GHC feels like it.
|
||||
-- The given argument lets you refresh a ModSummary log_action
|
||||
withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([(WarnReason, FileDiagnostic)], a)
|
||||
withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)
|
||||
withWarnings diagSource action = do
|
||||
warnings <- liftIO $ newVar []
|
||||
oldFlags <- getDynFlags
|
||||
warnings <- newVar []
|
||||
let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
newAction dynFlags wr _ loc style msg = do
|
||||
let wr_d = fmap (wr,) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg
|
||||
modifyVar_ warnings $ return . (wr_d:)
|
||||
setLogAction newAction
|
||||
res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}}
|
||||
setLogAction $ log_action oldFlags
|
||||
warns <- liftIO $ readVar warnings
|
||||
warns <- readVar warnings
|
||||
return (reverse $ concat warns, res)
|
||||
|
||||
setLogAction :: GhcMonad m => LogAction -> m ()
|
||||
setLogAction act = void $ modifyDynFlags $ \dyn -> dyn{log_action = act}
|
||||
|
@ -1,30 +0,0 @@
|
||||
module Development.IDE.GHC.WithDynFlags
|
||||
( WithDynFlags
|
||||
, evalWithDynFlags
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Reader (ask, ReaderT(..))
|
||||
import GHC (DynFlags)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Exception (ExceptionMonad(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import GhcPlugins (HasDynFlags(..))
|
||||
|
||||
-- | A monad transformer implementing the 'HasDynFlags' effect
|
||||
newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}
|
||||
deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)
|
||||
|
||||
evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a
|
||||
evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags
|
||||
|
||||
instance Monad m => HasDynFlags (WithDynFlags m) where
|
||||
getDynFlags = WithDynFlags ask
|
||||
|
||||
instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where
|
||||
gmask f = WithDynFlags $ ReaderT $ \env ->
|
||||
gmask $ \restore ->
|
||||
let restore' = lift . restore . flip runReaderT env . withDynFlags
|
||||
in runReaderT (withDynFlags $ f restore') env
|
||||
|
||||
gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->
|
||||
gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)
|
@ -80,7 +80,7 @@ produceCompletions = do
|
||||
buf = fromJust $ ms_hspp_buf ms
|
||||
f = fromNormalizedFilePath file
|
||||
dflags = hsc_dflags env
|
||||
pm <- liftIO $ evalGhcEnv env $ runExceptT $ parseHeader dflags f buf
|
||||
pm <- liftIO $ runExceptT $ parseHeader dflags f buf
|
||||
case pm of
|
||||
Right (_diags, hsMod) -> do
|
||||
let hsModNoExports = hsMod <&> \x -> x{hsmodExports = Nothing}
|
||||
@ -92,7 +92,7 @@ produceCompletions = do
|
||||
}
|
||||
tm <- liftIO $ typecheckModule (IdeDefer True) env Nothing pm
|
||||
case tm of
|
||||
(_, Just (_,tcm)) -> do
|
||||
(_, Just tcm) -> do
|
||||
cdata <- liftIO $ cacheDataProducer env tcm parsedDeps
|
||||
-- Do not return diags from parsing as they would duplicate
|
||||
-- the diagnostics from typechecking
|
||||
|
@ -289,14 +289,14 @@ cacheDataProducer packageState tm deps = do
|
||||
varToCompl var = do
|
||||
let typ = Just $ varType var
|
||||
name = Var.varName var
|
||||
docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tmrParsed tm : deps) name
|
||||
docs <- getDocumentationTryGhc packageState curMod (tmrParsed tm : deps) name
|
||||
return $ mkNameCompItem name curModName typ Nothing docs
|
||||
|
||||
toCompItem :: Module -> ModuleName -> Name -> IO CompItem
|
||||
toCompItem m mn n = do
|
||||
docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tmrParsed tm : deps) n
|
||||
ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do
|
||||
name' <- lookupName m n
|
||||
docs <- getDocumentationTryGhc packageState curMod (tmrParsed tm : deps) n
|
||||
ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
|
||||
name' <- lookupName packageState m n
|
||||
return $ name' >>= safeTyThingType
|
||||
return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs
|
||||
|
||||
|
@ -39,14 +39,15 @@ import Language.Haskell.LSP.Types (getUri, filePathToUri)
|
||||
import TcRnTypes
|
||||
import ExtractDocs
|
||||
import NameEnv
|
||||
import HscTypes (HscEnv(hsc_dflags))
|
||||
|
||||
mkDocMap
|
||||
:: GhcMonad m
|
||||
=> [ParsedModule]
|
||||
:: HscEnv
|
||||
-> [ParsedModule]
|
||||
-> RefMap
|
||||
-> TcGblEnv
|
||||
-> m DocAndKindMap
|
||||
mkDocMap sources rm this_mod =
|
||||
-> IO DocAndKindMap
|
||||
mkDocMap env sources rm this_mod =
|
||||
do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
|
||||
d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
|
||||
k <- foldrM getType (tcg_type_env this_mod) names
|
||||
@ -55,29 +56,29 @@ mkDocMap sources rm this_mod =
|
||||
getDocs n map
|
||||
| maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist
|
||||
| otherwise = do
|
||||
doc <- getDocumentationTryGhc mod sources n
|
||||
doc <- getDocumentationTryGhc env mod sources n
|
||||
pure $ extendNameEnv map n doc
|
||||
getType n map
|
||||
| isTcOcc $ occName n = do
|
||||
kind <- lookupKind mod n
|
||||
kind <- lookupKind env mod n
|
||||
pure $ maybe map (extendNameEnv map n) kind
|
||||
| otherwise = pure map
|
||||
names = rights $ S.toList idents
|
||||
idents = M.keysSet rm
|
||||
mod = tcg_mod this_mod
|
||||
|
||||
lookupKind :: GhcMonad m => Module -> Name -> m (Maybe TyThing)
|
||||
lookupKind mod =
|
||||
fmap (either (const Nothing) id) . catchSrcErrors "span" . lookupName mod
|
||||
lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
|
||||
lookupKind env mod =
|
||||
fmap (either (const Nothing) id) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
|
||||
|
||||
getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc
|
||||
getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]
|
||||
getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc
|
||||
getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n]
|
||||
|
||||
getDocumentationsTryGhc :: GhcMonad m => Module -> [ParsedModule] -> [Name] -> m [SpanDoc]
|
||||
getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc]
|
||||
-- Interfaces are only generated for GHC >= 8.6.
|
||||
-- In older versions, interface files do not embed Haddocks anyway
|
||||
getDocumentationsTryGhc mod sources names = do
|
||||
res <- catchSrcErrors "docs" $ getDocsBatch mod names
|
||||
getDocumentationsTryGhc env mod sources names = do
|
||||
res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names
|
||||
case res of
|
||||
Left _ -> mapM mkSpanDocText names
|
||||
Right res -> zipWithM unwrap res names
|
||||
@ -90,7 +91,7 @@ getDocumentationsTryGhc mod sources names = do
|
||||
|
||||
-- Get the uris to the documentation and source html pages if they exist
|
||||
getUris name = do
|
||||
df <- getSessionDynFlags
|
||||
let df = hsc_dflags env
|
||||
(docFu, srcFu) <-
|
||||
case nameModule_maybe name of
|
||||
Just mod -> liftIO $ do
|
||||
|
Loading…
Reference in New Issue
Block a user