Abstract Monad for interface creation

I found that when running as a plugin the lookupName function (which
runs in Ghc monad) does not work correctly from the
typeCheckResultAction hook.

Instead, we abstracted the monad used when creating interfaces, so
that access to GHC session specific parts is explicit and so that the
TcM can provide their (correct) implementation of lookupName.

Author: alexbiehl-gc

haddock-api/haddock-api.cabal

@@ -60,6 +60,7 @@ library
                , exceptions
                , filepath
                , ghc-boot
+               , mtl
                , transformers
 
   hs-source-dirs: src
@@ -192,6 +193,7 @@ test-suite spec
                , exceptions
                , filepath
                , ghc-boot
+               , mtl
                , transformers
 
   build-tool-depends:

haddock-api/src/Haddock/GhcUtils.hs

@@ -30,9 +30,7 @@ import GHC.Utils.Outputable ( Outputable, panic, showPpr )
 import GHC.Types.Basic (PromotionFlag(..))
 import GHC.Types.Name
 import GHC.Unit.Module
-import GHC.Driver.Types
 import GHC
-import GHC.Core.Class
 import GHC.Driver.Session
 import GHC.Types.SrcLoc  ( advanceSrcLoc )
 import GHC.Types.Var     ( Specificity, VarBndr(..), TyVarBinder
@@ -526,14 +524,6 @@ modifySessionDynFlags f = do
   return ()
 
 
--- Extract the minimal complete definition of a Name, if one exists
-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
-minimalDef n = do
-  mty <- lookupGlobalName n
-  case mty of
-    Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
-    _ -> return Nothing
-
 -------------------------------------------------------------------------------
 -- * DynFlags
 -------------------------------------------------------------------------------
@@ -766,4 +756,3 @@ defaultRuntimeRepVars = go emptyVarEnv
 
     go _ ty@(LitTy {}) = ty
     go _ ty@(CoercionTy {}) = ty
-

haddock-api/src/Haddock/Interface.hs

@@ -55,10 +55,11 @@ import GHC hiding (verbosity)
 import GHC.Data.Graph.Directed
 import GHC.Driver.Session hiding (verbosity)
 import GHC.Driver.Types (isBootSummary)
-import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
+import GHC.Driver.Monad (modifySession)
 import GHC.Data.FastString (unpackFS)
-import GHC.Tc.Types (TcGblEnv(..))
-import GHC.Tc.Utils.Monad (getTopEnv)
+import GHC.Tc.Types (TcM, TcGblEnv(..))
+import GHC.Tc.Utils.Monad (setGblEnv)
+import GHC.Tc.Utils.Env (tcLookupGlobal)
 import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
 import GHC.Types.Name.Occurrence (isTcOcc)
 import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts)
@@ -200,7 +201,7 @@ plugin verbosity flags instIfaceMap = liftIO $ do
   moduleSetRef <- newIORef emptyModuleSet
 
   let
-    processTypeCheckedResult :: ModSummary -> TcGblEnv -> Ghc ()
+    processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
     processTypeCheckedResult mod_summary tc_gbl_env
       -- Don't do anything for hs-boot modules
       | IsBoot <- isBootSummary mod_summary =
@@ -225,11 +226,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do
           paPlugin = defaultPlugin
           {
             renamedResultAction = keepRenamedSource
-          , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do
-              session <- getTopEnv >>= liftIO . newIORef
-              liftIO $ reflectGhc
-                (processTypeCheckedResult mod_summary tc_gbl_env)
-                (Session session)
+          , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
+              processTypeCheckedResult mod_summary tc_gbl_env
               pure tc_gbl_env
 
           }
@@ -244,31 +242,28 @@ plugin verbosity flags instIfaceMap = liftIO $ do
     )
 
 
-
 processModule1
   :: Verbosity
   -> [Flag]
   -> IfaceMap
   -> InstIfaceMap
   -> ModSummary
   -> TcGblEnv
-  -> Ghc (Interface, ModuleSet)
+  -> TcM (Interface, ModuleSet)
 processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do
   out verbosity verbose "Creating interface..."
 
   let
     TcGblEnv { tcg_rdr_env } = tc_gbl_env
 
   (!interface, messages) <- {-# SCC createInterface #-}
-    withTimingD "createInterface" (const ()) $
-      runWriterGhc $ createInterface1 flags mod_summary
-        tc_gbl_env ifaces inst_ifaces
+    withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+      createInterface1 flags mod_summary tc_gbl_env ifaces inst_ifaces
 
   -- We need to keep track of which modules were somehow in scope so that when
   -- Haddock later looks for instances, it also looks in these modules too.
   --
   -- See https://github.com/haskell/haddock/issues/469.
-
   dflags <- getDynFlags
   let
     mods :: ModuleSet