From b93c6351afdfaf452ad9830a5f8536a353320a84 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alex@groundcloud.com>
Date: Thu, 7 Jan 2021 23:40:56 +0100
Subject: [PATCH] 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.
---
 haddock-api/haddock-api.cabal                 |   2 +
 haddock-api/src/Haddock/GhcUtils.hs           |  11 -
 haddock-api/src/Haddock/Interface.hs          |  25 +-
 haddock-api/src/Haddock/Interface/Create.hs   | 383 ++++++++----------
 .../src/Haddock/Interface/LexParseRn.hs       |   1 +
 haddock-api/src/Haddock/Options.hs            |   3 +-
 haddock-api/src/Haddock/Types.hs              |  71 ++--
 .../fixtures/examples/linkInlineMarkup.parsed |   5 +-
 html-test/ref/Bug1033.html                    |  12 +-
 html-test/ref/Bug1050.html                    |   2 +-
 html-test/ref/Bug574.html                     |   2 +-
 html-test/ref/Bug679.html                     |   2 +-
 html-test/ref/Bug8.html                       |   2 +-
 html-test/ref/BundledPatterns.html            |   2 +-
 html-test/ref/BundledPatterns2.html           |   2 +-
 html-test/ref/QuasiExpr.html                  |   2 +-
 html-test/ref/QuasiQuote.html                 |   2 +-
 html-test/ref/TH.html                         |   2 +-
 html-test/ref/TH2.html                        |   2 +-
 html-test/ref/Threaded.html                   |   2 +-
 html-test/ref/Ticket112.html                  |   2 +-
 21 files changed, 224 insertions(+), 313 deletions(-)

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index f3dbe2e2c4..2389540dd6 100644
--- a/haddock-api/haddock-api.cabal
+++ b/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:
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 10725ee5db..d12b79ad5f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/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
-
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 7bd092da39..dab84bebf8 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/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,7 +242,6 @@ plugin verbosity flags instIfaceMap = liftIO $ do
     )
 
 
-
 processModule1
   :: Verbosity
   -> [Flag]
@@ -252,7 +249,7 @@ processModule1
   -> 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..."
 
@@ -260,15 +257,13 @@ processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do
     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
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 9f177ca8cd..308d7d4165 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -Wwarn #-}
 -----------------------------------------------------------------------------
 -- |
@@ -18,25 +20,24 @@
 -- which creates a Haddock 'Interface' from the typechecking
 -- results 'TypecheckedModule' from GHC.
 -----------------------------------------------------------------------------
-module Haddock.Interface.Create (createInterface, createInterface1) where
+module Haddock.Interface.Create (IfM, runIfM, createInterface1) where
 
 import Documentation.Haddock.Doc (metaDocAppend)
-import Haddock.Types
+import Haddock.Types hiding (liftErrMsg)
 import Haddock.Options
 import Haddock.GhcUtils
 import Haddock.Utils
 import Haddock.Convert
 import Haddock.Interface.LexParseRn
 
-import Control.Monad.IO.Class
-import Data.Bifunctor
+import Control.Monad.Catch
+import Control.Monad.Reader
+import Control.Monad.Writer.Strict hiding (tell)
 import Data.Bitraversable
 import qualified Data.Map as M
-import qualified Data.Set as S
 import Data.Map (Map)
 import Data.List (find, foldl')
 import Data.Maybe
-import Control.Monad
 import Data.Traversable
 import GHC.Stack (HasCallStack)
 
@@ -44,34 +45,103 @@ import GHC.Tc.Utils.Monad (finalSafeMode)
 import GHC.Types.Avail hiding (avail)
 import qualified GHC.Types.Avail  as Avail
 import qualified GHC.Unit.Module as Module
+-- <<<<<<< HEAD
 import qualified GHC.Types.SrcLoc as SrcLoc
+import GHC.Core.Class ( ClassMinimalDef, classMinimalDef )
 import GHC.Core.ConLike (ConLike(..))
-import GHC
+import GHC hiding ( lookupName )
 import GHC.Driver.Types
+-- =======
+-- import GHC.Unit.Module.ModSummary
+-- import qualified GHC.Types.SrcLoc as SrcLoc
+-- import GHC.Types.SourceFile
+-- import GHC.Core.Class
+-- import GHC.Core.ConLike (ConLike(..))
+-- import GHC hiding (lookupName)
+-- import GHC.Driver.Ppr
+-- >>>>>>> 703e5f02... Abstract Monad for interface creation
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Name.Env
 import GHC.Unit.State
 import GHC.Types.Name.Reader
-import GHC.Tc.Types
+import GHC.Tc.Types hiding (IfM)
 import GHC.Data.FastString ( unpackFS, bytesFS )
 import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
 import qualified GHC.Utils.Outputable as O
 import GHC.HsToCore.Docs hiding (mkMaps)
 import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 
-mkExceptionContext :: TypecheckedModule -> String
+
+mkExceptionContext :: ModSummary -> String
 mkExceptionContext =
-  ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
+  ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name
+
+
+newtype IfEnv m = IfEnv
+  {
+    -- | Lookup names in the enviroment.
+    ife_lookup_name :: Name -> m (Maybe TyThing)
+  }
+
+
+-- | A monad in which we create Haddock interfaces. Not to be confused with
+-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.
+--
+-- In the past `createInterface` was running in the `Ghc` monad but proved hard
+-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting
+-- over the Ghc specific clarifies where side effects happen.
+newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a }
+
+deriving newtype instance Functor m => Functor (IfM m)
+deriving newtype instance Applicative m => Applicative (IfM m)
+deriving newtype instance Monad m => Monad (IfM m)
+deriving newtype instance MonadIO m => MonadIO (IfM m)
+deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m)
+deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)
+deriving newtype instance (MonadThrow m) => MonadThrow (IfM m)
+deriving newtype instance (MonadCatch m) => MonadCatch (IfM m)
+
+
+-- | Run an `IfM` action.
+runIfM
+  -- | Lookup a global name in the current session. Used in cases
+  -- where declarations don't
+  :: (Name -> m (Maybe TyThing))
+  -- | The action to run.
+  -> IfM m a
+  -- | Result and accumulated error/warning messages.
+  -> m (a, [ErrMsg])
+runIfM lookup_name action = do
+  let
+    if_env = IfEnv
+      {
+        ife_lookup_name = lookup_name
+      }
+  runWriterT (runReaderT (unIfM action) if_env)
+
+
+liftErrMsg :: Monad m => ErrMsgM a -> IfM m a
+liftErrMsg action = do
+  writer (runWriter action)
+
+
+lookupName :: Monad m => Name -> IfM m (Maybe TyThing)
+lookupName name = IfM $ do
+  lookup_name <- asks ife_lookup_name
+  lift $ lift (lookup_name name)
+
 
 createInterface1
-  :: [Flag]
+  :: (MonadIO m, MonadCatch m)
+  => [Flag]
   -> ModSummary
   -> TcGblEnv
   -> IfaceMap
   -> InstIfaceMap
-  -> ErrMsgGhc Interface
-createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
+  -> IfM m Interface
+createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces =
+  withExceptionContext (mkExceptionContext mod_sum) $ do
 
   let
     ModSummary
@@ -132,7 +202,7 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
 
   decls <- case tcg_rn_decls of
     Nothing -> do
-      liftErrMsg $ tell [ "Warning: Renamed source is not available" ]
+      tell [ "Warning: Renamed source is not available" ]
       pure []
     Just dx ->
       pure (topDecls dx)
@@ -152,9 +222,16 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
           Nothing
 
     -- All the exported Names of this module.
+    actual_exports :: [AvailInfo]
+    actual_exports
+      | OptIgnoreExports `elem` doc_opts  =
+          gresToAvailInfo $ filter isLocalGRE $ globalRdrEnvElts tcg_rdr_env
+      | otherwise =
+          tcg_exports
+
     exported_names :: [Name]
     exported_names =
-      concatMap availNamesWithSelectors tcg_exports
+      concatMap availNamesWithSelectors actual_exports
 
     -- Module imports of the form `import X`. Note that there is
     -- a) no qualification and
@@ -197,7 +274,7 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
 
   export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod
     warnings tcg_rdr_env exported_names (map fst decls) maps fixities
-    imported_modules loc_splices export_list tcg_exports inst_ifaces dflags
+    imported_modules loc_splices export_list actual_exports inst_ifaces dflags
 
   let
     visible_names :: [Name]
@@ -248,156 +325,6 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
     }
 
 
--- | Use a 'TypecheckedModule' to produce an 'Interface'.
--- To do this, we need access to already processed modules in the topological
--- sort. That's what's in the 'IfaceMap'.
-createInterface :: HasCallStack
-                => TypecheckedModule
-                -> [Flag]       -- Boolean flags
-                -> IfaceMap     -- Locally processed modules
-                -> InstIfaceMap -- External, already installed interfaces
-                -> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap =
- withExceptionContext (mkExceptionContext tm) $ do
-
-  let ms             = pm_mod_summary . tm_parsed_module $ tm
-      mi             = moduleInfo tm
-      L _ hsm        = parsedSource tm
-      !safety        = modInfoSafe mi
-      mdl            = ms_mod ms
-      sem_mdl        = tcg_semantic_mod (fst (tm_internals_ tm))
-      is_sig         = ms_hsc_src ms == HsigFile
-      dflags         = ms_hspp_opts ms
-      !instances     = modInfoInstances mi
-      !fam_instances = md_fam_insts md
-      !exportedNames = modInfoExportsWithSelectors mi
-      (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)
-      pkgName        = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
-
-      (TcGblEnv { tcg_rdr_env = gre
-                , tcg_warns   = warnings
-                , tcg_exports = all_exports0
-                }, md) = tm_internals_ tm
-      all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre
-
-  -- The 'pkgName' is necessary to decide what package to mention in "@since"
-  -- annotations. Not having it is not fatal though.
-  --
-  -- Cabal can be trusted to pass the right flags, so this warning should be
-  -- mostly encountered when running Haddock outside of Cabal.
-  when (isNothing pkgName) $
-    liftErrMsg $ tell [ "Warning: Package name is not available." ]
-
-  -- The renamed source should always be available to us, but it's best
-  -- to be on the safe side.
-  (group_, imports, mayExports, mayDocHeader) <-
-    case renamedSource tm of
-      Nothing -> do
-        liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
-        return (emptyRnGroup, [], Nothing, Nothing)
-      Just x -> return x
-
-  opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
-
-  -- Process the top-level module header documentation.
-  (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader
-
-  let declsWithDocs = topDecls group_
-
-      exports0 = fmap (map (first unLoc)) mayExports
-      (all_exports, exports)
-        | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)
-        | otherwise = (all_exports0, exports0)
-
-      unrestrictedImportedMods
-        -- module re-exports are only possible with
-        -- explicit export list
-        | Just{} <- exports
-        = unrestrictedModuleImports (map unLoc imports)
-        | otherwise = M.empty
-
-      fixMap = mkFixMap group_
-      (decls, _) = unzip declsWithDocs
-      localInsts = filter (nameIsLocalOrFrom sem_mdl)
-                        $  map getName fam_instances
-                        ++ map getName instances
-      -- Locations of all TH splices
-      splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
-
-  warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
-
-  maps@(!docMap, !argMap, !declMap, _) <-
-    liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs)
-
-  let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-
-  -- The MAIN functionality: compute the export items which will
-  -- each be the actual documentation of this module.
-  exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre
-                   exportedNames decls maps fixMap unrestrictedImportedMods
-                   splices exports all_exports instIfaceMap dflags
-
-  let !visibleNames = mkVisibleNames maps exportItems opts
-
-  -- Measure haddock documentation coverage.
-  let prunedExportItems0 = pruneExportItems exportItems
-      !haddockable = 1 + length exportItems -- module + exports
-      !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
-      !coverage = (haddockable, haddocked)
-
-  -- Prune the export list to just those declarations that have
-  -- documentation, if the 'prune' option is on.
-  let prunedExportItems'
-        | OptPrune `elem` opts = prunedExportItems0
-        | otherwise = exportItems
-      !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
-
-  let !aliases =
-        mkAliasMap (unitState dflags) imports
-  modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
-
-  -- Prune the docstring 'Map's to keep only docstrings that are not private.
-  --
-  -- Besides all the names that GHC has told us this module exports, we also
-  -- keep the docs for locally defined class instances. This is more names than
-  -- we need, but figuring out which instances are fully private is tricky.
-  --
-  -- We do this pruning to avoid having to rename, emit warnings, and save
-  -- docstrings which will anyways never be rendered.
-  let !localVisibleNames = S.fromList (localInsts ++ exportedNames)
-      !prunedDocMap = M.restrictKeys docMap localVisibleNames
-      !prunedArgMap = M.restrictKeys argMap localVisibleNames
-
-  return $! Interface {
-    ifaceMod               = mdl
-  , ifaceIsSig             = is_sig
-  , ifaceOrigFilename      = msHsFilePath ms
-  , ifaceInfo              = info
-  , ifaceDoc               = Documentation mbDoc modWarn
-  , ifaceRnDoc             = Documentation Nothing Nothing
-  , ifaceOptions           = opts
-  , ifaceDocMap            = prunedDocMap
-  , ifaceArgMap            = prunedArgMap
-  , ifaceRnDocMap          = M.empty -- Filled in `renameInterface`
-  , ifaceRnArgMap          = M.empty -- Filled in `renameInterface`
-  , ifaceExportItems       = prunedExportItems
-  , ifaceRnExportItems     = [] -- Filled in `renameInterface`
-  , ifaceExports           = exportedNames
-  , ifaceVisibleExports    = visibleNames
-  , ifaceDeclMap           = declMap
-  , ifaceFixMap            = fixMap
-  , ifaceModuleAliases     = aliases
-  , ifaceInstances         = instances
-  , ifaceFamInstances      = fam_instances
-  , ifaceOrphanInstances   = [] -- Filled in `attachInstances`
-  , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
-  , ifaceHaddockCoverage   = coverage
-  , ifaceWarningMap        = warningMap
-  , ifaceHieFile           = Just $ ml_hie_file $ ms_location ms
-  , ifaceDynFlags          = dflags
-  }
-
-
 -- | Given all of the @import M as N@ declarations in a package,
 -- create a mapping from the module identity of M, to an alias N
 -- (if there are multiple aliases, we pick the last one.)  This
@@ -652,7 +579,7 @@ mkFixMap group_ =
 -- We create the export items even if the module is hidden, since they
 -- might be useful when creating the export items for other modules.
 mkExportItems
-  :: HasCallStack
+  :: (Monad m)
   => Bool               -- is it a signature
   -> IfaceMap
   -> Maybe Package      -- this package
@@ -670,7 +597,7 @@ mkExportItems
   -> Avails             -- exported stuff from this module
   -> InstIfaceMap
   -> DynFlags
-  -> ErrMsgGhc [ExportItem GhcRn]
+  -> IfM m [ExportItem GhcRn]
 mkExportItems
   is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls
   maps fixMap unrestricted_imp_mods splices exportList allExports
@@ -712,25 +639,39 @@ mkExportItems
       availExportItem is_sig modMap thisMod semMod warnings exportedNames
         maps fixMap splices instIfaceMap dflags avail
 
-availExportItem :: HasCallStack
-                => Bool               -- is it a signature
-                -> IfaceMap
-                -> Module             -- this module
-                -> Module             -- semantic module
-                -> WarningMap
-                -> [Name]             -- exported names (orig)
-                -> Maps
-                -> FixMap
-                -> [SrcSpan]          -- splice locations
-                -> InstIfaceMap
-                -> DynFlags
-                -> AvailInfo
-                -> ErrMsgGhc [ExportItem GhcRn]
+
+-- Extract the minimal complete definition of a Name, if one exists
+minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef)
+minimalDef n = do
+  mty <- lookupName n
+  case mty of
+    Just (ATyCon (tyConClass_maybe -> Just c)) ->
+      return . Just $ classMinimalDef c
+    _ ->
+      return Nothing
+
+
+availExportItem
+  :: forall m
+  .  Monad m
+  => Bool               -- is it a signature
+  -> IfaceMap
+  -> Module             -- this module
+  -> Module             -- semantic module
+  -> WarningMap
+  -> [Name]             -- exported names (orig)
+  -> Maps
+  -> FixMap
+  -> [SrcSpan]          -- splice locations
+  -> InstIfaceMap
+  -> DynFlags
+  -> AvailInfo
+  -> IfM m [ExportItem GhcRn]
 availExportItem is_sig modMap thisMod semMod warnings exportedNames
   (docMap, argMap, declMap, _) fixMap splices instIfaceMap
   dflags availInfo = declWith availInfo
   where
-    declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ]
+    declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ]
     declWith avail = do
       let t = availName avail
       r    <- findDecl avail
@@ -767,7 +708,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
                     in availExportDecl avail newDecl docs_
 
                   L loc (TyClD _ cl@ClassDecl{}) -> do
-                    mdef <- liftGhcToErrMsgGhc $ minimalDef t
+                    mdef <- minimalDef t
                     let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef
                     availExportDecl avail
                       (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_
@@ -796,7 +737,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
         _ -> return []
 
     -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
-    availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)
+    availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
     availDecl declName parentDecl =
       case extractDecl declMap declName parentDecl of
         Right d -> pure d
@@ -808,7 +749,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
 
     availExportDecl :: AvailInfo -> LHsDecl GhcRn
                     -> (DocForDecl Name, [(Name, DocForDecl Name)])
-                    -> ErrMsgGhc [ ExportItem GhcRn ]
+                    -> IfM m [ ExportItem GhcRn ]
     availExportDecl avail decl (doc, subs)
       | availExportsDecl avail = do
           extractedDecl <- availDecl (availName avail) decl
@@ -854,7 +795,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
     exportedNameSet = mkNameSet exportedNames
     isExported n = elemNameSet n exportedNameSet
 
-    findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
+    findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
     findDecl avail
       | m == semMod =
           case M.lookup n declMap of
@@ -883,10 +824,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
         n = availName avail
         m = nameModule n
 
-    findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]
+    findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]
     findBundledPatterns avail = do
       patsyns <- for constructor_names $ \name -> do
-        mtyThing <- liftGhcToErrMsgGhc (lookupName name)
+        mtyThing <- lookupName name
         case mtyThing of
           Just (AConLike PatSynCon{}) -> do
             export_items <- declWith (Avail.avail name)
@@ -925,9 +866,9 @@ semToIdMod this_uid m
     | otherwise             = m
 
 -- | Reify a declaration from the GHC internal 'TyThing' representation.
-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
+hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn))
 hiDecl dflags t = do
-  mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
+  mayTyThing <- lookupName t
   case mayTyThing of
     Nothing -> do
       liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
@@ -946,8 +887,9 @@ hiDecl dflags t = do
 -- It gets the type signature from GHC and that means it's not going to
 -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
 -- declaration and use it instead - 'nLoc' here.
-hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
-                -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn)
+hiValExportItem
+  :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
+  -> Maybe Fixity -> IfM m (ExportItem GhcRn)
 hiValExportItem dflags name nLoc doc splice fixity = do
   mayDecl <- hiDecl dflags name
   case mayDecl of
@@ -977,12 +919,14 @@ lookupDocs avail warnings docMap argMap =
 
 -- | Export the given module as `ExportModule`. We are not concerned with the
 -- single export items of the given module.
-moduleExport :: Module           -- ^ Module A (identity, NOT semantic)
-             -> DynFlags         -- ^ The flags used when typechecking A
-             -> IfaceMap         -- ^ Already created interfaces
-             -> InstIfaceMap     -- ^ Interfaces in other packages
-             -> ModuleName       -- ^ The exported module
-             -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items
+moduleExport
+  :: Monad m
+  => Module           -- ^ Module A (identity, NOT semantic)
+  -> DynFlags         -- ^ The flags used when typechecking A
+  -> IfaceMap         -- ^ Already created interfaces
+  -> InstIfaceMap     -- ^ Interfaces in other packages
+  -> ModuleName       -- ^ The exported module
+  -> IfM m [ExportItem GhcRn] -- ^ Resulting export items
 moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
     -- NB: we constructed the identity module when looking up in
     -- the IfaceMap.
@@ -996,9 +940,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
         case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
           Just iface -> return [ ExportModule (instMod iface) ]
           Nothing -> do
-            liftErrMsg $
-              tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
-                    "documentation for exported module: " ++ pretty dflags expMod]
+            liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+                               "documentation for exported module: " ++ pretty dflags expMod]
             return []
   where
     m = mkModule (moduleUnit thisMod) expMod -- Identity module!
@@ -1024,22 +967,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
 -- every locally defined declaration is exported; thus, we just
 -- zip through the renamed declarations.
 
-fullModuleContents :: Bool               -- is it a signature
-                   -> IfaceMap
-                   -> Maybe Package      -- this package
-                   -> Module             -- this module
-                   -> Module             -- semantic module
-                   -> WarningMap
-                   -> GlobalRdrEnv      -- ^ The renaming environment
-                   -> [Name]             -- exported names (orig)
-                   -> [LHsDecl GhcRn]    -- renamed source declarations
-                   -> Maps
-                   -> FixMap
-                   -> [SrcSpan]          -- splice locations
-                   -> InstIfaceMap
-                   -> DynFlags
-                   -> Avails
-                   -> ErrMsgGhc [ExportItem GhcRn]
+fullModuleContents
+  :: Monad m
+  => Bool               -- is it a signature
+  -> IfaceMap
+  -> Maybe Package      -- this package
+  -> Module             -- this module
+  -> Module             -- semantic module
+  -> WarningMap
+  -> GlobalRdrEnv      -- ^ The renaming environment
+  -> [Name]             -- exported names (orig)
+  -> [LHsDecl GhcRn]    -- renamed source declarations
+  -> Maps
+  -> FixMap
+  -> [SrcSpan]          -- splice locations
+  -> InstIfaceMap
+  -> DynFlags
+  -> Avails
+  -> IfM m [ExportItem GhcRn]
 fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames
   decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
   let availEnv = availsToNameEnv (nubAvails avails)
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 87210273c8..2ada67d13d 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -Wwarn #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
   -----------------------------------------------------------------------------
 -- |
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index b86bb4fb2d..b24079456a 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -47,9 +47,10 @@ import           Data.Version
 import           Control.Applicative
 import           GHC.Data.FastString
 import           GHC ( DynFlags, Module, moduleUnit, unitState )
+import           GHC.Unit.Info ( PackageName(..), unitPackageName, unitPackageVersion )
+import           GHC.Unit.State ( lookupUnit  )
 import           Haddock.Types
 import           Haddock.Utils
-import           GHC.Unit.State
 import           System.Console.GetOpt
 import qualified Text.ParserCombinators.ReadP as RP
 
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 53d01565d4..e38568ab0f 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -3,6 +3,9 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -----------------------------------------------------------------------------
@@ -25,14 +28,17 @@ module Haddock.Types (
   , HsDocString, LHsDocString
   , Fixity(..)
   , module Documentation.Haddock.Types
+
+  -- $ Reexports
+  , runWriter
+  , tell
  ) where
 
-import Control.Arrow hiding ((<+>))
 import Control.DeepSeq
 import Control.Exception (throw)
-import Control.Monad (ap)
 import Control.Monad.Catch
 import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT)
 import Data.Typeable (Typeable)
 import Data.Map (Map)
 import Data.Data (Data)
@@ -628,26 +634,7 @@ data SinceQual
 
 
 type ErrMsg = String
-newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
-
-
-instance Functor ErrMsgM where
-        fmap f (Writer (a, msgs)) = Writer (f a, msgs)
-
-instance Applicative ErrMsgM where
-    pure a = Writer (a, [])
-    (<*>)  = ap
-
-instance Monad ErrMsgM where
-        return   = pure
-        m >>= k  = Writer $ let
-                (a, w)  = runWriter m
-                (b, w') = runWriter (k a)
-                in (b, w ++ w')
-
-
-tell :: [ErrMsg] -> ErrMsgM ()
-tell w = Writer ((), w)
+type ErrMsgM = Writer [ErrMsg]
 
 
 -- Exceptions
@@ -681,40 +668,30 @@ withExceptionContext ctxt =
 -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
 -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
 -- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
---instance MonadIO ErrMsgGhc where
---  liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
---er, implementing GhcMonad involves annoying ExceptionMonad and
---WarnLogMonad classes, so don't bother.
-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
-liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
-liftErrMsg = WriterGhc . return . runWriter
---  for now, use (liftErrMsg . tell) for this
---tell :: [ErrMsg] -> ErrMsgGhc ()
---tell msgs = WriterGhc $ return ( (), msgs )
+newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a }
 
 
-instance Functor ErrMsgGhc where
-  fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
+deriving newtype instance Functor ErrMsgGhc
+deriving newtype instance Applicative ErrMsgGhc
+deriving newtype instance Monad ErrMsgGhc
+deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc
+deriving newtype instance MonadIO ErrMsgGhc
 
-instance Applicative ErrMsgGhc where
-    pure a = WriterGhc (return (a, []))
-    (<*>) = ap
 
-instance Monad ErrMsgGhc where
-  return = pure
-  m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
-               fmap (second (msgs1 ++)) (runWriterGhc (k a))
+runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg])
+runWriterGhc = runWriterT . unErrMsgGhc
 
-instance MonadIO ErrMsgGhc where
-  liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
+liftGhcToErrMsgGhc = ErrMsgGhc . lift
+
+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
+liftErrMsg = writer . runWriter
 
 instance MonadThrow ErrMsgGhc where
-  throwM e = WriterGhc (throwM e)
+  throwM e = ErrMsgGhc (throwM e)
 
 instance MonadCatch ErrMsgGhc where
-  catch (WriterGhc m) f = WriterGhc (catch m (runWriterGhc . f))
+  catch (ErrMsgGhc m) f = ErrMsgGhc (catch m (unErrMsgGhc . f))
 
 -----------------------------------------------------------------------------
 -- * Pass sensitive types
diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.parsed b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
index 39adab6419..fbef2bf3fe 100644
--- a/haddock-library/fixtures/examples/linkInlineMarkup.parsed
+++ b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
@@ -3,6 +3,7 @@ DocParagraph
      (DocString "Bla ")
      (DocHyperlink
         Hyperlink
-          {hyperlinkLabel = Just (DocAppend (DocString "link ")
-                                            (DocEmphasis (DocString "emphasized"))),
+          {hyperlinkLabel = Just
+                              (DocAppend
+                                 (DocString "link ") (DocEmphasis (DocString "emphasized"))),
            hyperlinkUrl = "http://example.com"}))
diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html
index 736fb2ad44..362544477a 100644
--- a/html-test/ref/Bug1033.html
+++ b/html-test/ref/Bug1033.html
@@ -88,10 +88,8 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc"
-		  ><p
-		    >This does some generic foos.</p
-		    ></td
+		  ><td class="doc empty"
+		  >&nbsp;</td
 		  ></tr
 		><tr
 		><td colspan="2"
@@ -166,8 +164,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  >&nbsp;</td
+		  ><td class="doc"
+		  ><p
+		    >This does some generic foos.</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html
index b8b8ff0fb1..da7ae1d219 100644
--- a/html-test/ref/Bug1050.html
+++ b/html-test/ref/Bug1050.html
@@ -95,7 +95,7 @@
 	    >forall</span
 	    > {k} {f :: <span class="keyword"
 	    >forall</span
-	    > k1. k1 -&gt; <a href="#" title="Data.Kind"
+	    > k. k -&gt; <a href="#" title="Data.Kind"
 	    >Type</a
 	    >} {a :: k}. f a -&gt; <a href="#" title="Bug1050"
 	    >T</a
diff --git a/html-test/ref/Bug574.html b/html-test/ref/Bug574.html
index 3c7cf13f75..e2024f477b 100644
--- a/html-test/ref/Bug574.html
+++ b/html-test/ref/Bug574.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/Bug679.html b/html-test/ref/Bug679.html
index 2434a85723..8814129d9c 100644
--- a/html-test/ref/Bug679.html
+++ b/html-test/ref/Bug679.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html
index 7389084559..4d6fe69bb1 100644
--- a/html-test/ref/Bug8.html
+++ b/html-test/ref/Bug8.html
@@ -89,7 +89,7 @@
 	><p class="src"
 	  ><a id="v:-45--45--62-" class="def"
 	    >(--&gt;)</a
-	    > :: p1 -&gt; p2 -&gt; <a href="#" title="Bug8"
+	    > :: p -&gt; p -&gt; <a href="#" title="Bug8"
 	    >Typ</a
 	    > <span class="fixity"
 	    >infix 9</span
diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html
index fb6518aff0..f3a1010daa 100644
--- a/html-test/ref/BundledPatterns.html
+++ b/html-test/ref/BundledPatterns.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html
index b680fe6666..9ef3a85da5 100644
--- a/html-test/ref/BundledPatterns2.html
+++ b/html-test/ref/BundledPatterns2.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html
index 2eb2cda392..e3c7b6e7de 100644
--- a/html-test/ref/QuasiExpr.html
+++ b/html-test/ref/QuasiExpr.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/QuasiQuote.html b/html-test/ref/QuasiQuote.html
index d828ea1d7a..1ea5109967 100644
--- a/html-test/ref/QuasiQuote.html
+++ b/html-test/ref/QuasiQuote.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/TH.html b/html-test/ref/TH.html
index 8ef49cedd3..d44d57416e 100644
--- a/html-test/ref/TH.html
+++ b/html-test/ref/TH.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/TH2.html b/html-test/ref/TH2.html
index f59629a29a..1b47e6409a 100644
--- a/html-test/ref/TH2.html
+++ b/html-test/ref/TH2.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html
index 3277c468ca..8391431ed7 100644
--- a/html-test/ref/Threaded.html
+++ b/html-test/ref/Threaded.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
diff --git a/html-test/ref/Ticket112.html b/html-test/ref/Ticket112.html
index 9d04e8c59a..bd596be0bf 100644
--- a/html-test/ref/Ticket112.html
+++ b/html-test/ref/Ticket112.html
@@ -36,7 +36,7 @@
 	  ><th
 	    >Safe Haskell</th
 	    ><td
-	    >None</td
+	    >Safe-Inferred</td
 	    ></tr
 	  ></table
 	><p class="caption"
-- 
GitLab