From b6b983b4125770286057048dc3a7d24cfe8e87c1 Mon Sep 17 00:00:00 2001 From: wz1000 Date: Fri, 23 Oct 2020 12:20:53 +0530 Subject: [PATCH] simplify things unnecessarily running in GhcM (haskell/ghcide#875) * simplify things unnecessarily running in GhcM * untick catchSrcErrors * set useUnicode --- ghcide/ghcide.cabal | 1 - .../session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Core/Compile.hs | 132 ++++++++---------- .../src/Development/IDE/Core/Preprocessor.hs | 21 ++- ghcide/src/Development/IDE/Core/Rules.hs | 7 +- ghcide/src/Development/IDE/GHC/Error.hs | 18 ++- ghcide/src/Development/IDE/GHC/Util.hs | 1 - ghcide/src/Development/IDE/GHC/Warnings.hs | 15 +- .../src/Development/IDE/GHC/WithDynFlags.hs | 30 ---- .../src/Development/IDE/Plugin/Completions.hs | 4 +- .../IDE/Plugin/Completions/Logic.hs | 8 +- .../Development/IDE/Spans/Documentation.hs | 31 ++-- 12 files changed, 107 insertions(+), 163 deletions(-) delete mode 100644 ghcide/src/Development/IDE/GHC/WithDynFlags.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 182a52cb6a..5d244e9981 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -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 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index ce0471c46a..6e7239027d 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -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 { diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 65be2d9410..dd9bf1a016 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -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 "") 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 diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index e24aa13c39..0f70a5f0b3 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index d9b367440e..1c1e367f83 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -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 diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index 59c3876fe6..e147c2541d 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -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 diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 76cc705eba..18afc7c90b 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -10,7 +10,6 @@ module Development.IDE.GHC.Util( envImportPaths, modifyDynFlags, evalGhcEnv, - runGhcEnv, deps, -- * GHC wrappers prettyPrint, diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 354d8f0f16..68c52cf982 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -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} diff --git a/ghcide/src/Development/IDE/GHC/WithDynFlags.hs b/ghcide/src/Development/IDE/GHC/WithDynFlags.hs deleted file mode 100644 index 702a291482..0000000000 --- a/ghcide/src/Development/IDE/GHC/WithDynFlags.hs +++ /dev/null @@ -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) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index ed6fd53b83..46fbd89c49 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index f89ce47882..b2d27f5c3b 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 7a7a168886..2c9e638faa 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -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