simplify things unnecessarily running in GhcM (#875)

* simplify things unnecessarily running in GhcM

* untick catchSrcErrors

* set useUnicode

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

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
   {

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 "<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

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

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

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

src/Development/IDE/GHC/Util.hs

@@ -10,7 +10,6 @@ module Development.IDE.GHC.Util(
     envImportPaths,
     modifyDynFlags,
     evalGhcEnv,
-    runGhcEnv,
     deps,
     -- * GHC wrappers
     prettyPrint,

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}

src/Development/IDE/GHC/WithDynFlags.hs

@@ -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)

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

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
 

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