template-haskell: Add putDoc, getDoc, withDecDoc and friends

This adds two new methods to the Quasi class, putDoc and getDoc. They
allow Haddock documentation to be added to declarations, module headers,
function arguments and class/type family instances, as well as looked
up.

It works by building up a map of names to attach pieces of
documentation to, which are then added in the extractDocs function in
GHC.HsToCore.Docs. However because these template haskell names need to
be resolved to GHC names at the time they are added, putDoc cannot
directly add documentation to declarations that are currently being
spliced. To remedy this, withDecDoc/withDecsDoc wraps the operation with
addModFinalizer, and provides a more ergonomic interface for doing so.
Similarly, the funD_doc, dataD_doc etc. combinators provide a more
ergonomic interface for documenting functions and their arguments
simultaneously.

This also changes ArgDocMap to use an IntMap rather than an Map Int, for
efficiency.

Part of the work towards #5467

32 files changed, 968 insertions, 52 deletions

diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs
index 207b65f2fd..425cc03bf0 100644
--- a/compiler/GHC/Hs/Doc.hs
+++ b/compiler/GHC/Hs/Doc.hs
@@ -19,6 +19,8 @@ module GHC.Hs.Doc
 
   , ArgDocMap(..)
   , emptyArgDocMap
+
+  , ExtractedTHDocs(..)
   ) where
 
 #include "HsVersions.h"
@@ -35,6 +37,8 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8
 import Data.Data
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe
@@ -126,21 +130,34 @@ emptyDeclDocMap :: DeclDocMap
 emptyDeclDocMap = DeclDocMap Map.empty
 
 -- | Docs for arguments. E.g. function arguments, method arguments.
-newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString))
+newtype ArgDocMap = ArgDocMap (Map Name (IntMap HsDocString))
 
 instance Binary ArgDocMap where
-  put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m))
+  put_ bh (ArgDocMap m) = put_ bh (Map.toList (IntMap.toAscList <$> m))
   -- We can't rely on a deterministic ordering of the `Name`s here.
   -- See the comments on `Name`'s `Ord` instance for context.
-  get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh
+  get bh = ArgDocMap . fmap IntMap.fromDistinctAscList . Map.fromList <$> get bh
 
 instance Outputable ArgDocMap where
   ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))
     where
       pprPair (name, int_map) =
         ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map)
-      pprIntMap im = vcat (map pprIPair (Map.toAscList im))
+      pprIntMap im = vcat (map pprIPair (IntMap.toAscList im))
       pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc)
 
 emptyArgDocMap :: ArgDocMap
 emptyArgDocMap = ArgDocMap Map.empty
+
+-- | Maps of docs that were added via Template Haskell's @putDoc@.
+data ExtractedTHDocs =
+  ExtractedTHDocs
+    { ethd_mod_header :: Maybe HsDocString
+      -- ^ The added module header documentation, if it exists.
+    , ethd_decl_docs  :: DeclDocMap
+      -- ^ The documentation added to declarations.
+    , ethd_arg_docs   :: ArgDocMap
+      -- ^ The documentation added to function arguments.
+    , ethd_inst_docs  :: DeclDocMap
+      -- ^ The documentation added to class and family instances.
+    }
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index bf15fd2e10..fafcdb6533 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -214,7 +214,7 @@ deSugar hsc_env
 
         ; foreign_files <- readIORef th_foreign_files_var
 
-        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
+        ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env
 
         ; let mod_guts = ModGuts {
                 mg_module       = mod,
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 56f089a756..fa278b7983 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -27,15 +27,22 @@ import GHC.Types.SrcLoc
 import GHC.Tc.Types
 
 import Control.Applicative
+import Control.Monad.IO.Class
 import Data.Bifunctor (first)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IM
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Semigroup
+import GHC.IORef (readIORef)
 
 -- | Extract docs from renamer output.
-extractDocs :: TcGblEnv
-            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
+-- This is monadic since we need to be able to read documentation added from
+-- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'.
+extractDocs :: MonadIO m
+            => TcGblEnv
+            -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)
             -- ^
             -- 1. Module header
             -- 2. Docs on top level declarations
@@ -45,8 +52,20 @@ extractDocs TcGblEnv { tcg_semantic_mod = mod
                      , tcg_insts = insts
                      , tcg_fam_insts = fam_insts
                      , tcg_doc_hdr = mb_doc_hdr
-                     } =
-    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
+                     , tcg_th_docs = th_docs_var
+                     } = do
+    th_docs <- liftIO $ readIORef th_docs_var
+    let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr)
+        ExtractedTHDocs
+          th_doc_hdr
+          (DeclDocMap th_doc_map)
+          (ArgDocMap th_arg_map)
+          (DeclDocMap th_inst_map) = extractTHDocs th_docs
+    return
+      ( doc_hdr
+      , DeclDocMap (th_doc_map <> th_inst_map <> doc_map)
+      , ArgDocMap (th_arg_map `unionArgMaps` arg_map)
+      )
   where
     (doc_map, arg_map) = maybe (M.empty, M.empty)
                                (mkMaps local_insts)
@@ -59,10 +78,10 @@ extractDocs TcGblEnv { tcg_semantic_mod = mod
 -- For each declaration, find its names, its subordinates, and its doc strings.
 mkMaps :: [Name]
        -> [(LHsDecl GhcRn, [HsDocString])]
-       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
+       -> (Map Name (HsDocString), Map Name (IntMap HsDocString))
 mkMaps instances decls =
     ( f' (map (nubByName fst) decls')
-    , f  (filterMapping (not . M.null) args)
+    , f  (filterMapping (not . IM.null) args)
     )
   where
     (decls', args) = unzip (map mappings decls)
@@ -78,7 +97,7 @@ mkMaps instances decls =
 
     mappings :: (LHsDecl GhcRn, [HsDocString])
              -> ( [(Name, HsDocString)]
-                , [(Name, Map Int (HsDocString))]
+                , [(Name, IntMap HsDocString)]
                 )
     mappings (L (RealSrcSpan l _) decl, docStrs) =
            (dm, am)
@@ -86,7 +105,7 @@ mkMaps instances decls =
         doc = concatDocs docStrs
         args = declTypeDocs decl
 
-        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
+        subs :: [(Name, [HsDocString], IntMap HsDocString)]
         subs = subordinates instanceMap decl
 
         (subDocs, subArgs) =
@@ -162,13 +181,13 @@ getInstLoc = \case
 -- family of a type class.
 subordinates :: Map RealSrcSpan Name
              -> HsDecl GhcRn
-             -> [(Name, [(HsDocString)], Map Int (HsDocString))]
+             -> [(Name, [HsDocString], IntMap HsDocString)]
 subordinates instMap decl = case decl of
   InstD _ (ClsInstD _ d) -> do
     DataFamInstDecl { dfid_eqn =
       FamEqn { feqn_tycon = L l _
              , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d
-    [ (n, [], M.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn
+    [ (n, [], IM.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn
 
   InstD _ (DataFamInstD _ (DataFamInstDecl d))
     -> dataSubs (feqn_rhs d)
@@ -181,7 +200,7 @@ subordinates instMap decl = case decl of
                    , name <- getMainDeclBinder d, not (isValD d)
                    ]
     dataSubs :: HsDataDefn GhcRn
-             -> [(Name, [HsDocString], Map Int (HsDocString))]
+             -> [(Name, [HsDocString], IntMap HsDocString)]
     dataSubs dd = constrs ++ fields ++ derivs
       where
         cons = map unLoc $ (dd_cons dd)
@@ -189,11 +208,11 @@ subordinates instMap decl = case decl of
                     , maybeToList $ fmap unLoc $ con_doc c
                     , conArgDocs c)
                   | c <- cons, cname <- getConNames c ]
-        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, IM.empty)
                   | Just flds <- map getRecConArgs_maybe cons
                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
                   , (L _ n) <- ns ]
-        derivs  = [ (instName, [unLoc doc], M.empty)
+        derivs  = [ (instName, [unLoc doc], IM.empty)
                   | (l, doc) <- concatMap (extract_deriv_clause_tys .
                                            deriv_clause_tys . unLoc) $
                                 unLoc $ dd_derivs dd
@@ -213,26 +232,26 @@ subordinates instMap decl = case decl of
             _               -> Nothing
 
 -- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
+conArgDocs :: ConDecl GhcRn -> IntMap HsDocString
 conArgDocs (ConDeclH98{con_args = args}) =
   h98ConArgDocs args
 conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
   gadtConArgDocs args (unLoc res_ty)
 
-h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString
+h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString
 h98ConArgDocs con_args = case con_args of
   PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
   InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
                                        , unLoc (hsScaledThing arg2) ]
-  RecCon _           -> M.empty
+  RecCon _           -> IM.empty
 
-gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> Map Int HsDocString
+gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString
 gadtConArgDocs con_args res_ty = case con_args of
   PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
   RecConGADT _       -> con_arg_docs 1 [res_ty]
 
-con_arg_docs :: Int -> [HsType GhcRn] -> Map Int HsDocString
-con_arg_docs n = M.fromList . catMaybes . zipWith f [n..]
+con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString
+con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]
   where
     f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
     f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
@@ -254,14 +273,14 @@ classDecls class_ = filterDecls . collectDocs . sortLocated $ decls
     ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
 
 -- | Extract function argument docs from inside top-level decls.
-declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
+declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString)
 declTypeDocs = \case
   SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))
   SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)
   SigD  _ (PatSynSig _ _ ty)        -> sigTypeDocs (unLoc ty)
   ForD  _ (ForeignImport _ _ ty _)  -> sigTypeDocs (unLoc ty)
   TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
-  _                                 -> M.empty
+  _                                 -> IM.empty
 
 nubByName :: (a -> Name) -> [a] -> [a]
 nubByName f ns = go emptyNameSet ns
@@ -275,19 +294,19 @@ nubByName f ns = go emptyNameSet ns
         y = f x
 
 -- | Extract function argument docs from inside types.
-typeDocs :: HsType GhcRn -> Map Int (HsDocString)
+typeDocs :: HsType GhcRn -> IntMap HsDocString
 typeDocs = go 0
   where
     go n = \case
       HsForAllTy { hst_body = ty }          -> go n (unLoc ty)
       HsQualTy   { hst_body = ty }          -> go n (unLoc ty)
-      HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)
+      HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty)
       HsFunTy _ _ _ ty                      -> go (n+1) (unLoc ty)
-      HsDocTy _ _ doc                       -> M.singleton n (unLoc doc)
-      _                                     -> M.empty
+      HsDocTy _ _ doc                       -> IM.singleton n (unLoc doc)
+      _                                     -> IM.empty
 
 -- | Extract function argument docs from inside types.
-sigTypeDocs :: HsSigType GhcRn -> Map Int HsDocString
+sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString
 sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)
 
 -- | The top-level declarations of a module that we care about,
@@ -372,3 +391,62 @@ mkDecls :: (struct -> [Located decl])
         -> struct
         -> [Located hsDecl]
 mkDecls field con = map (mapLoc con) . field
+
+-- | Extracts out individual maps of documentation added via Template Haskell's
+-- @putDoc@.
+extractTHDocs :: THDocs
+              -> ExtractedTHDocs
+extractTHDocs docs =
+  -- Split up docs into separate maps for each 'DocLoc' type
+  ExtractedTHDocs
+    docHeader
+    (DeclDocMap (searchDocs decl))
+    (ArgDocMap (searchDocs args))
+    (DeclDocMap (searchDocs insts))
+  where
+    docHeader :: Maybe HsDocString
+    docHeader
+      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s)
+      | otherwise = Nothing
+
+    isModDoc (ModuleDoc, _) = True
+    isModDoc _ = False
+
+    -- Folds over the docs, applying 'f' as the accumulating function.
+    -- We use different accumulating functions to sift out the specific types of
+    -- documentation
+    searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a
+    searchDocs f = foldl' f mempty $ M.toList docs
+
+    -- Pick out the declaration docs
+    decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc
+    decl acc _ = acc
+
+    -- Pick out the instance docs
+    insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc
+    insts acc _ = acc
+
+    -- Pick out the argument docs
+    args :: Map Name (IntMap HsDocString)
+         -> (DocLoc, String)
+         -> Map Name (IntMap HsDocString)
+    args acc ((ArgDoc name i), s) =
+      -- Insert the doc for the arg into the argument map for the function. This
+      -- means we have to search to see if an map already exists for the
+      -- function, and insert the new argument if it exists, or create a new map
+      let ds = mkHsDocString s
+       in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc
+    args acc _ = acc
+
+-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
+-- maps with values for the same key merge the inner map as well.
+-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
+unionArgMaps :: Map Name (IntMap b)
+             -> Map Name (IntMap b)
+             -> Map Name (IntMap b)
+unionArgMaps a b = M.foldlWithKey go b a
+  where
+    go acc n newArgMap
+      | Just oldArgMap <- M.lookup n acc =
+          M.insert n (newArgMap `IM.union` oldArgMap) acc
+      | otherwise = M.insert n newArgMap acc
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 53f0032f28..323f69f0d3 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -212,7 +212,7 @@ mkIfaceTc hsc_env safe_mode mod_details
           usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names
                       dep_files merged pluginModules
 
-          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
+          (doc_hdr', doc_map, arg_map) <- extractDocs tc_result
 
           let partial_iface = mkIface_ hsc_env
                    this_mod hsc_src
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index c2626ce6b3..fc2f8b8ab3 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -117,9 +117,9 @@ import GHC.Unit.Home.ModInfo
 import System.Directory
 import Data.Dynamic
 import Data.Either
+import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.List (find,intercalate)
-import Data.Map (Map)
 import qualified Data.Map as Map
 import Control.Monad
 import Control.Monad.Catch as MC
@@ -879,7 +879,7 @@ parseName str = withSession $ \hsc_env -> liftIO $
 
 getDocs :: GhcMonad m
         => Name
-        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
+        -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
            -- TODO: What about docs for constructors etc.?
 getDocs name =
   withSession $ \hsc_env -> do
@@ -896,7 +896,7 @@ getDocs name =
              if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
                then pure (Left (NoDocsInIface mod compiled))
                else pure (Right ( Map.lookup name dmap
-                                , Map.findWithDefault Map.empty name amap))
+                                , Map.findWithDefault mempty name amap))
   where
     compiled =
       -- TODO: Find a more direct indicator.
diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs
index 109a4416bc..b89f5c8a6c 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs
+++ b/compiler/GHC/Tc/Errors/Hole.hs
@@ -419,7 +419,7 @@ addDocs :: [HoleFit] -> TcM [HoleFit]
 addDocs fits =
   do { showDocs <- goptM Opt_ShowDocsOfHoleFits
      ; if showDocs
-       then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv
+       then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs
                ; mapM (upd lclDocs) fits }
        else return fits }
   where
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 7ae4ccb0f6..89ba997d8a 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -68,6 +68,7 @@ import GHC.Builtin.Names
 import GHC.Builtin.Types
 
 import GHC.ThToHs
+import GHC.HsToCore.Docs
 import GHC.HsToCore.Expr
 import GHC.HsToCore.Monad
 import GHC.IfaceToCore
@@ -147,6 +148,7 @@ import Data.Maybe
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Dynamic  ( fromDynamic, toDyn )
+import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
 import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
 import Data.Data (Data)
@@ -1220,6 +1222,148 @@ instance TH.Quasi TcM where
   qExtsEnabled =
     EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
 
+  qPutDoc doc_loc s = do
+    th_doc_var <- tcg_th_docs <$> getGblEnv
+    resolved_doc_loc <- resolve_loc doc_loc
+    is_local <- checkLocalName resolved_doc_loc
+    unless is_local $ failWithTc $ text
+      "Can't add documentation to" <+> ppr_loc doc_loc <+>
+      text "as it isn't inside the current module"
+    updTcRef th_doc_var (Map.insert resolved_doc_loc s)
+    where
+      resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n
+      resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i
+      resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t)
+      resolve_loc TH.ModuleDoc = pure ModuleDoc
+
+      ppr_loc (TH.DeclDoc n) = ppr_th n
+      ppr_loc (TH.ArgDoc n _) = ppr_th n
+      ppr_loc (TH.InstDoc t) = ppr_th t
+      ppr_loc TH.ModuleDoc = text "the module header"
+
+      -- It doesn't make sense to add documentation to something not inside
+      -- the current module. So check for it!
+      checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
+      checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n
+      checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
+      checkLocalName ModuleDoc = pure True
+
+
+  qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
+  qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
+  qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
+  qGetDoc TH.ModuleDoc = do
+    (moduleDoc, _, _) <- getGblEnv >>= extractDocs
+    return (fmap unpackHDS moduleDoc)
+
+-- | Looks up documentation for a declaration in first the current module,
+-- otherwise tries to find it in another module via 'hscGetModuleInterface'.
+lookupDeclDoc :: Name -> TcM (Maybe String)
+lookupDeclDoc nm = do
+  (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs
+  fam_insts <- tcg_fam_insts <$> getGblEnv
+  traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts)
+  case Map.lookup nm declDocs of
+    Just doc -> pure $ Just (unpackHDS doc)
+    Nothing -> do
+      -- Wasn't in the current module. Try searching other external ones!
+      mIface <- getExternalModIface nm
+      case mIface of
+        Nothing -> pure Nothing
+        Just ModIface { mi_decl_docs = DeclDocMap dmap } ->
+          pure $ unpackHDS <$> Map.lookup nm dmap
+
+-- | Like 'lookupDeclDoc', looks up documentation for a function argument. If
+-- it can't find any documentation for a function in this module, it tries to
+-- find it in another module.
+lookupArgDoc :: Int -> Name -> TcM (Maybe String)
+lookupArgDoc i nm = do
+  (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs
+  case Map.lookup nm argDocs of
+    Just m -> pure $ unpackHDS <$> IntMap.lookup i m
+    Nothing -> do
+      mIface <- getExternalModIface nm
+      case mIface of
+        Nothing -> pure Nothing
+        Just ModIface { mi_arg_docs = ArgDocMap amap } ->
+          pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i)
+
+-- | Returns the module a Name belongs to, if it is isn't local.
+getExternalModIface :: Name -> TcM (Maybe ModIface)
+getExternalModIface nm = do
+  isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm
+  if isLocal
+    then pure Nothing
+    else case nameModule_maybe nm of
+          Nothing -> pure Nothing
+          Just modNm -> do
+            hsc_env <- getTopEnv
+            iface <- liftIO $ hscGetModuleInterface hsc_env modNm
+            pure (Just iface)
+
+-- | Find the GHC name of the first instance that matches the TH type
+lookupThInstName :: TH.Type -> TcM Name
+lookupThInstName th_type = do
+  cls_name <- inst_cls_name th_type
+  insts <- reifyInstances' cls_name (inst_arg_types th_type)
+  case insts of   -- This expands any type synonyms
+    Left  (_, (inst:_)) -> return $ getName inst
+    Left  (_, [])       -> noMatches
+    Right (_, (inst:_)) -> return $ getName inst
+    Right (_, [])       -> noMatches
+  where
+    noMatches = failWithTc $
+      text "Couldn't find any instances of"
+        <+> ppr_th th_type
+        <+> text "to add documentation to"
+
+    -- | Get the name of the class for the instance we are documenting
+    -- > inst_cls_name (Monad Maybe) == Monad
+    -- > inst_cls_name C = C
+    inst_cls_name :: TH.Type -> TcM TH.Name
+    inst_cls_name (TH.AppT t _)           = inst_cls_name t
+    inst_cls_name (TH.SigT n _)           = inst_cls_name n
+    inst_cls_name (TH.VarT n)             = pure n
+    inst_cls_name (TH.ConT n)             = pure n
+    inst_cls_name (TH.PromotedT n)        = pure n
+    inst_cls_name (TH.InfixT _ n _)       = pure n
+    inst_cls_name (TH.UInfixT _ n _)      = pure n
+    inst_cls_name (TH.ParensT t)          = inst_cls_name t
+
+    inst_cls_name (TH.ForallT _ _ _)      = inst_cls_name_err
+    inst_cls_name (TH.ForallVisT _ _)     = inst_cls_name_err
+    inst_cls_name (TH.AppKindT _ _)       = inst_cls_name_err
+    inst_cls_name (TH.TupleT _)           = inst_cls_name_err
+    inst_cls_name (TH.UnboxedTupleT _)    = inst_cls_name_err
+    inst_cls_name (TH.UnboxedSumT _)      = inst_cls_name_err
+    inst_cls_name TH.ArrowT               = inst_cls_name_err
+    inst_cls_name TH.MulArrowT            = inst_cls_name_err
+    inst_cls_name TH.EqualityT            = inst_cls_name_err
+    inst_cls_name TH.ListT                = inst_cls_name_err
+    inst_cls_name (TH.PromotedTupleT _)   = inst_cls_name_err
+    inst_cls_name TH.PromotedNilT         = inst_cls_name_err
+    inst_cls_name TH.PromotedConsT        = inst_cls_name_err
+    inst_cls_name TH.StarT                = inst_cls_name_err
+    inst_cls_name TH.ConstraintT          = inst_cls_name_err
+    inst_cls_name (TH.LitT _)             = inst_cls_name_err
+    inst_cls_name TH.WildCardT            = inst_cls_name_err
+    inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err
+
+    inst_cls_name_err = failWithTc $
+      text "Couldn't work out what instance"
+        <+> ppr_th th_type
+        <+> text "is supposed to be"
+
+    -- | Basically does the opposite of 'mkThAppTs'
+    -- > inst_arg_types (Monad Maybe) == [Maybe]
+    -- > inst_arg_types C == []
+    inst_arg_types :: TH.Type -> [TH.Type]
+    inst_arg_types (TH.AppT _ args) =
+      let go (TH.AppT t ts) = t:go ts
+          go t = [t]
+        in go args
+    inst_arg_types _ = []
+
 -- | Adds a mod finalizer reference to the local environment.
 addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
 addModFinalizerRef finRef = do
@@ -1411,6 +1555,8 @@ handleTHMessage msg = case msg of
   AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
   IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
   ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
+  PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
+  GetDoc l -> wrapTHResult $ TH.qGetDoc l
   FailIfErrs -> wrapTHResult failIfErrsM
   _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
 
@@ -1434,6 +1580,19 @@ getAnnotationsByTypeRep th_name tyrep
 
 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
 reifyInstances th_nm th_tys
+  = do { insts <- reifyInstances' th_nm th_tys
+       ; case insts of
+           Left (cls, cls_insts) ->
+             reifyClassInstances cls cls_insts
+           Right (tc, fam_insts) ->
+             reifyFamilyInstances tc fam_insts }
+
+reifyInstances' :: TH.Name
+                -> [TH.Type]
+                -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst]))
+                -- ^ Returns 'Left' in the case that the instances were found to
+                -- be class instances, or 'Right' if they are family instances.
+reifyInstances' th_nm th_tys
    = addErrCtxt (text "In the argument of reifyInstances:"
                  <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
      do { loc <- getSrcSpanM
@@ -1467,19 +1626,19 @@ reifyInstances th_nm th_tys
                 -- In particular, the type might have kind
                 -- variables inside it (#7477)
 
-        ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty))
+        ; traceTc "reifyInstances'" (ppr ty $$ ppr (tcTypeKind ty))
         ; case splitTyConApp_maybe ty of   -- This expands any type synonyms
             Just (tc, tys)                 -- See #7910
                | Just cls <- tyConClass_maybe tc
                -> do { inst_envs <- tcGetInstEnvs
                      ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
-                     ; traceTc "reifyInstances1" (ppr matches)
-                     ; reifyClassInstances cls (map fst matches ++ unifies) }
+                     ; traceTc "reifyInstances'1" (ppr matches)
+                     ; return $ Left (cls, map fst matches ++ unifies) }
                | isOpenFamilyTyCon tc
                -> do { inst_envs <- tcGetFamInstEnvs
                      ; let matches = lookupFamInstEnv inst_envs tc tys
-                     ; traceTc "reifyInstances2" (ppr matches)
-                     ; reifyFamilyInstances tc (map fim_instance matches) }
+                     ; traceTc "reifyInstances'2" (ppr matches)
+                     ; return $ Right (tc, map fim_instance matches) }
             _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))
                                2 (text "is not a class constraint or type family application")) }
   where
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 9e9e82bca4..81cf5ea408 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -283,6 +283,14 @@ tcRnModuleTcRnM hsc_env mod_sum
           tcg_env <- {-# SCC "tcRnImports" #-}
                      tcRnImports hsc_env all_imports
 
+       ;  -- Don't need to rename the Haddock documentation,
+          -- it's not parsed by GHC anymore.
+          -- Make sure to do this before 'tcRnSrcDecls', because we need the
+          -- module header when we're splicing TH, since it can be accessed via
+          -- 'getDoc'.
+          tcg_env <- return (tcg_env
+                              { tcg_doc_hdr = maybe_doc_hdr })
+
         ; -- If the whole module is warned about or deprecated
           -- (via mod_deprec) record that in tcg_warns. If we do thereby add
           -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
@@ -320,13 +328,8 @@ tcRnModuleTcRnM hsc_env mod_sum
                         -- because the latter might add new bindings for
                         -- boot_dfuns, which may be mentioned in imported
                         -- unfoldings.
-
-                        -- Don't need to rename the Haddock documentation,
-                        -- it's not parsed by GHC anymore.
-                        tcg_env <- return (tcg_env
-                                           { tcg_doc_hdr = maybe_doc_hdr })
-                      ; -- Report unused names
-                        -- Do this /after/ type inference, so that when reporting
+                        -- Report unused names
+                        -- Do this /after/ typeinference, so that when reporting
                         -- a function with no type signature we can give the
                         -- inferred type
                         reportUnusedNames tcg_env hsc_src
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 0003a93169..2c9be13dff 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -55,7 +55,7 @@ module GHC.Tc.Types(
         ThStage(..), SpliceType(..), PendingStuff(..),
         topStage, topAnnStage, topSpliceStage,
         ThLevel, impLevel, outerLevel, thLevel,
-        ForeignSrcLang(..),
+        ForeignSrcLang(..), THDocs, DocLoc(..),
 
         -- Arrows
         ArrowCtxt(..),
@@ -522,6 +522,9 @@ data TcGblEnv
         tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),
         -- ^ Template Haskell state
 
+        tcg_th_docs   :: TcRef THDocs,
+        -- ^ Docs added in Template Haskell via @putDoc@.
+
         tcg_ev_binds  :: Bag EvBind,        -- Top-level evidence bindings
 
         -- Things defined in this module, or (in GHCi)
@@ -1738,3 +1741,15 @@ lintGblEnv logger dflags tcg_env =
   liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms
   where
     axioms = typeEnvCoAxioms (tcg_type_env tcg_env)
+
+-- | This is a mirror of Template Haskell's DocLoc, but the TH names are
+-- resolved to GHC names.
+data DocLoc = DeclDoc Name
+            | ArgDoc Name Int
+            | InstDoc Name
+            | ModuleDoc
+  deriving (Eq, Ord)
+
+-- | The current collection of docs that Template Haskell has built up via
+-- putDoc.
+type THDocs = Map DocLoc String
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index a3c087c4da..873c9b9fd2 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -257,6 +257,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         th_coreplugins_var <- newIORef [] ;
         th_state_var         <- newIORef Map.empty ;
         th_remote_state_var  <- newIORef Nothing ;
+        th_docs_var          <- newIORef Map.empty ;
         let {
              -- bangs to avoid leaking the env (#19356)
              !dflags = hsc_dflags hsc_env ;
@@ -284,6 +285,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_th_coreplugins = th_coreplugins_var,
                 tcg_th_state         = th_state_var,
                 tcg_th_remote_state  = th_remote_state_var,
+                tcg_th_docs          = th_docs_var,
 
                 tcg_mod            = mod,
                 tcg_semantic_mod   = homeModuleInstantiation home_unit mod,
diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst
index 3b0022fb8a..131f694f6b 100644
--- a/docs/users_guide/9.2.1-notes.rst
+++ b/docs/users_guide/9.2.1-notes.rst
@@ -165,6 +165,19 @@ Runtime system
   is returned is controlled by the :rts-flag:`-Fd ⟨factor⟩`. Memory return
   is triggered by consecutive idle collections.
 
+Template Haskell
+~~~~~~~~~~~~~~~~
+
+- There are two new functions ``putDoc`` and ``getDoc``, which allow Haddock
+  documentation to be attached and read from module headers, declarations,
+  function arguments, class instances and family instances.
+  These functions are quite low level, so the ``withDecDoc`` function provides
+  a more ergonomic interface for this. Similarly ``funD_doc``, ``dataD_doc``
+  and friends provide an easy way to document functions and constructors
+  alongside their arguments simultaneously. ::
+
+    $(withDecsDoc "This does good things" [d| foo x = 42 |])
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 2f0dfcde8d..0ac6fe4d9c 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -122,8 +122,8 @@ import Data.List ( elemIndices, find, group, intercalate, intersperse,
                    isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
 import qualified Data.Set as S
 import Data.Maybe
-import Data.Map (Map)
 import qualified Data.Map as M
+import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IntMap
 import Data.Time.LocalTime ( getZonedTime )
 import Data.Time.Format ( formatTime, defaultTimeLocale )
@@ -1833,7 +1833,7 @@ data DocComponents =
   DocComponents
     { docs      :: Maybe HsDocString   -- ^ subject's haddocks
     , sigAndLoc :: Maybe SDoc          -- ^ type signature + category + location
-    , argDocs   :: Map Int HsDocString -- ^ haddocks for arguments
+    , argDocs   :: IntMap HsDocString -- ^ haddocks for arguments
     }
 
 buildDocComponents :: GHC.GhcMonad m => String -> Name -> m DocComponents
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index d21686a326..1018242210 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -265,6 +265,8 @@ data THMessage a where
   AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ())
   IsExtEnabled :: Extension -> THMessage (THResult Bool)
   ExtsEnabled :: THMessage (THResult [Extension])
+  PutDoc :: TH.DocLoc -> String -> THMessage (THResult ())
+  GetDoc :: TH.DocLoc -> THMessage (THResult (Maybe String))
 
   StartRecover :: THMessage ()
   EndRecover :: Bool -> THMessage ()
@@ -305,6 +307,8 @@ getTHMessage = do
     20 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
     21 -> THMsg <$> AddCorePlugin <$> get
     22 -> THMsg <$> ReifyType <$> get
+    23 -> THMsg <$> (PutDoc <$> get <*> get)
+    24 -> THMsg <$> GetDoc <$> get
     n -> error ("getTHMessage: unknown message " ++ show n)
 
 putTHMessage :: THMessage a -> Put
@@ -332,6 +336,8 @@ putTHMessage m = case m of
   AddForeignFilePath lang a   -> putWord8 20 >> put lang >> put a
   AddCorePlugin a             -> putWord8 21 >> put a
   ReifyType a                 -> putWord8 22 >> put a
+  PutDoc l s                  -> putWord8 23 >> put l >> put s
+  GetDoc l                    -> putWord8 24 >> put l
 
 
 data EvalOpts = EvalOpts
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 56e38c0244..f2325db1e1 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -209,6 +209,8 @@ instance TH.Quasi GHCiQ where
     return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
   qIsExtEnabled x = ghcCmd (IsExtEnabled x)
   qExtsEnabled = ghcCmd ExtsEnabled
+  qPutDoc l s = ghcCmd (PutDoc l s)
+  qGetDoc l = ghcCmd (GetDoc l)
 
 -- | The implementation of the 'StartTH' message: create
 -- a new IORef QState, and return a RemoteRef to it.
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 69326eb9d1..236229a9df 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -68,6 +68,7 @@ instance Binary TH.FamilyResultSig
 instance Binary TH.TypeFamilyHead
 instance Binary TH.PatSynDir
 instance Binary TH.PatSynArgs
+instance Binary TH.DocLoc
 
 -- We need Binary TypeRep for serializing annotations
 
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 2da2bd61c6..83432c14e3 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -90,6 +90,9 @@ module Language.Haskell.TH(
         Syntax.Specificity(..),
         FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType,
 
+    -- ** Documentation
+        putDoc, getDoc, DocLoc(..),
+
     -- * Library functions
     module Language.Haskell.TH.Lib,
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 3e05081619..de90df2bfd 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -124,7 +124,11 @@ module Language.Haskell.TH.Lib (
     implicitParamBindD,
 
     -- ** Reify
-    thisModule
+    thisModule,
+
+    -- ** Documentation
+    withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, dataInstD_doc,
+    newtypeInstD_doc, patSynD_doc
 
    ) where
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index a41d0a47b3..706d4a8c6a 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -981,3 +981,171 @@ thisModule :: Q Module
 thisModule = do
   loc <- location
   pure $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)
+
+--------------------------------------------------------------
+-- * Documentation combinators
+
+-- | Attaches Haddock documentation to the declaration provided. Unlike
+-- 'putDoc', the names do not need to be in scope when calling this function so
+-- it can be used for quoted declarations and anything else currently being
+-- spliced.
+-- Not all declarations can have documentation attached to them. For those that
+-- can't, 'withDecDoc' will return it unchanged without any side effects.
+withDecDoc :: String -> Q Dec -> Q Dec
+withDecDoc doc dec = do
+  dec' <- dec
+  case doc_loc dec' of
+    Just loc -> qAddModFinalizer $ qPutDoc loc doc
+    Nothing  -> pure ()
+  pure dec'
+  where
+    doc_loc (FunD n _)                                     = Just $ DeclDoc n
+    doc_loc (ValD (VarP n) _ _)                            = Just $ DeclDoc n
+    doc_loc (DataD _ n _ _ _ _)                            = Just $ DeclDoc n
+    doc_loc (NewtypeD _ n _ _ _ _)                         = Just $ DeclDoc n
+    doc_loc (TySynD n _ _)                                 = Just $ DeclDoc n
+    doc_loc (ClassD _ n _ _ _)                             = Just $ DeclDoc n
+    doc_loc (SigD n _)                                     = Just $ DeclDoc n
+    doc_loc (ForeignD (ImportF _ _ _ n _))                 = Just $ DeclDoc n
+    doc_loc (ForeignD (ExportF _ _ n _))                   = Just $ DeclDoc n
+    doc_loc (InfixD _ n)                                   = Just $ DeclDoc n
+    doc_loc (DataFamilyD n _ _)                            = Just $ DeclDoc n
+    doc_loc (OpenTypeFamilyD (TypeFamilyHead n _ _ _))     = Just $ DeclDoc n
+    doc_loc (ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _) = Just $ DeclDoc n
+    doc_loc (PatSynD n _ _ _)                              = Just $ DeclDoc n
+    doc_loc (PatSynSigD n _)                               = Just $ DeclDoc n
+
+    -- For instances we just pass along the full type
+    doc_loc (InstanceD _ _ t _)           = Just $ InstDoc t
+    doc_loc (DataInstD _ _ t _ _ _)       = Just $ InstDoc t
+    doc_loc (NewtypeInstD _ _ t _ _ _)    = Just $ InstDoc t
+    doc_loc (TySynInstD (TySynEqn _ t _)) = Just $ InstDoc t
+
+    -- Declarations that can't have documentation attached to
+    -- ValDs that aren't a simple variable pattern
+    doc_loc (ValD _ _ _)             = Nothing
+    doc_loc (KiSigD _ _)             = Nothing
+    doc_loc (PragmaD _)              = Nothing
+    doc_loc (RoleAnnotD _ _)         = Nothing
+    doc_loc (StandaloneDerivD _ _ _) = Nothing
+    doc_loc (DefaultSigD _ _)        = Nothing
+    doc_loc (ImplicitParamBindD _ _) = Nothing
+
+-- | Variant of 'withDecDoc' that applies the same documentation to
+-- multiple declarations. Useful for documenting quoted declarations.
+withDecsDoc :: String -> Q [Dec] -> Q [Dec]
+withDecsDoc doc decs = decs >>= mapM (withDecDoc doc . pure)
+
+-- | Variant of 'funD' that attaches Haddock documentation.
+funD_doc :: Name -> [Q Clause]
+         -> Maybe String -- ^ Documentation to attach to function
+         -> [Maybe String] -- ^ Documentation to attach to arguments
+         -> Q Dec
+funD_doc nm cs mfun_doc arg_docs = do
+  qAddModFinalizer $ sequence_
+    [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]
+  let dec = funD nm cs
+  case mfun_doc of
+    Just fun_doc -> withDecDoc fun_doc dec
+    Nothing -> funD nm cs
+
+-- | Variant of 'dataD' that attaches Haddock documentation.
+dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)
+          -> [(Q Con, Maybe String, [Maybe String])]
+          -- ^ List of constructors, documentation for the constructor, and
+          -- documentation for the arguments
+          -> [Q DerivClause]
+          -> Maybe String
+          -- ^ Documentation to attach to the data declaration
+          -> Q Dec
+dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do
+  qAddModFinalizer $ mapM_ docCons cons_with_docs
+  let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs
+  maybe dec (flip withDecDoc dec) mdoc
+
+-- | Variant of 'newtypeD' that attaches Haddock documentation.
+newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)
+             -> (Q Con, Maybe String, [Maybe String])
+             -- ^ The constructor, documentation for the constructor, and
+             -- documentation for the arguments
+             -> [Q DerivClause]
+             -> Maybe String
+             -- ^ Documentation to attach to the newtype declaration
+             -> Q Dec
+newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
+  qAddModFinalizer $ docCons con_with_docs
+  let dec = newtypeD ctxt tc tvs ksig con derivs
+  maybe dec (flip withDecDoc dec) mdoc
+
+-- | Variant of 'dataInstD' that attaches Haddock documentation.
+dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
+              -> [(Q Con, Maybe String, [Maybe String])]
+              -- ^ List of constructors, documentation for the constructor, and
+              -- documentation for the arguments
+              -> [Q DerivClause]
+              -> Maybe String
+              -- ^ Documentation to attach to the instance declaration
+              -> Q Dec
+dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do
+  qAddModFinalizer $ mapM_ docCons cons_with_docs
+  let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)
+              derivs
+  maybe dec (flip withDecDoc dec) mdoc
+
+-- | Variant of 'newtypeInstD' that attaches Haddock documentation.
+newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type
+                 -> Maybe (Q Kind)
+                 -> (Q Con, Maybe String, [Maybe String])
+                 -- ^ The constructor, documentation for the constructor, and
+                 -- documentation for the arguments
+                 -> [Q DerivClause]
+                 -> Maybe String
+                 -- ^ Documentation to attach to the instance declaration
+                 -> Q Dec
+newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do
+  qAddModFinalizer $ docCons con_with_docs
+  let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs
+  maybe dec (flip withDecDoc dec) mdoc
+
+-- | Variant of 'patSynD' that attaches Haddock documentation.
+patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat
+            -> Maybe String   -- ^ Documentation to attach to the pattern synonym
+            -> [Maybe String] -- ^ Documentation to attach to the pattern arguments
+            -> Q Dec
+patSynD_doc name args dir pat mdoc arg_docs = do
+  qAddModFinalizer $ sequence_
+    [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]
+  let dec = patSynD name args dir pat
+  maybe dec (flip withDecDoc dec) mdoc
+
+-- | Document a data/newtype constructor with its arguments.
+docCons :: (Q Con, Maybe String, [Maybe String]) -> Q ()
+docCons (c, md, arg_docs) = do
+  c' <- c
+  -- Attach docs to the constructors
+  sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- get_cons_names c' ]
+  -- Attach docs to the arguments
+  case c' of
+    -- Record selector documentation isn't stored in the argument map,
+    -- but in the declaration map instead
+    RecC _ var_bang_types ->
+      sequence_ [ putDoc (DeclDoc nm) arg_doc
+                  | (Just arg_doc, (nm, _, _)) <- zip arg_docs var_bang_types
+                ]
+    _ ->
+      sequence_ [ putDoc (ArgDoc nm i) arg_doc
+                    | nm <- get_cons_names c'
+                    , (i, Just arg_doc) <- zip [0..] arg_docs
+                ]
+  where
+    get_cons_names :: Con -> [Name]
+    get_cons_names (NormalC n _) = [n]
+    get_cons_names (RecC n _) = [n]
+    get_cons_names (InfixC _ n _) = [n]
+    get_cons_names (ForallC _ _ cons) = get_cons_names cons
+    -- GadtC can have multiple names, e.g
+    -- > data Bar a where
+    -- >   MkBar1, MkBar2 :: a -> Bar a
+    -- Will have one GadtC with [MkBar1, MkBar2] as names
+    get_cons_names (GadtC ns _ _) = ns
+    get_cons_names (RecGadtC ns _ _) = ns
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 3cb5a44ee8..d3c5a5eb45 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -123,6 +123,9 @@ class (MonadIO m, MonadFail m) => Quasi m where
   qIsExtEnabled :: Extension -> m Bool
   qExtsEnabled :: m [Extension]
 
+  qPutDoc :: DocLoc -> String -> m ()
+  qGetDoc :: DocLoc -> m (Maybe String)
+
 -----------------------------------------------------
 --      The IO instance of Quasi
 --
@@ -161,6 +164,8 @@ instance Quasi IO where
   qPutQ _               = badIO "putQ"
   qIsExtEnabled _       = badIO "isExtEnabled"
   qExtsEnabled          = badIO "extsEnabled"
+  qPutDoc _ _           = badIO "putDoc"
+  qGetDoc _             = badIO "getDoc"
 
 instance Quote IO where
   newName = newNameIO
@@ -745,6 +750,32 @@ isExtEnabled ext = Q (qIsExtEnabled ext)
 extsEnabled :: Q [Extension]
 extsEnabled = Q qExtsEnabled
 
+-- | Add Haddock documentation to the specified location. This will overwrite
+-- any documentation at the location if it already exists. This will reify the
+-- specified name, so it must be in scope when you call it. If you want to add
+-- documentation to something that you are currently splicing, you can use
+-- 'addModFinalizer' e.g.
+--
+-- > do
+-- >   let nm = mkName "x"
+-- >   addModFinalizer $ putDoc (DeclDoc nm) "Hello"
+-- >   [d| $(varP nm) = 42 |]
+--
+-- The helper functions 'withDecDoc' and 'withDecsDoc' will do this for you, as
+-- will the 'funD_doc' and other @_doc@ combinators.
+-- You most likely want to have the @-haddock@ flag turned on when using this.
+-- Adding documentation to anything outside of the current module will cause an
+-- error.
+putDoc :: DocLoc -> String -> Q ()
+putDoc t s = Q (qPutDoc t s)
+
+-- | Retreives the Haddock documentation at the specified location, if one
+-- exists.
+-- It can be used to read documentation on things defined outside of the current
+-- module, provided that those modules were compiled with the @-haddock@ flag.
+getDoc :: DocLoc -> Q (Maybe String)
+getDoc n = Q (qGetDoc n)
+
 instance MonadIO Q where
   liftIO = runIO
 
@@ -772,6 +803,8 @@ instance Quasi Q where
   qPutQ               = putQ
   qIsExtEnabled       = isExtEnabled
   qExtsEnabled        = extsEnabled
+  qPutDoc             = putDoc
+  qGetDoc             = getDoc
 
 
 ----------------------------------------------------
@@ -2625,6 +2658,17 @@ constructors):
                     (PromotedConsT  `AppT` IO `AppT` PromotedNilT)
 -}
 
+-- | A location at which to attach Haddock documentation.
+-- Note that adding documentation to a 'Name' defined oustide of the current
+-- module will cause an error.
+data DocLoc
+  = ModuleDoc         -- ^ At the current module's header.
+  | DeclDoc Name      -- ^ At a declaration, not necessarily top level.
+  | ArgDoc Name Int   -- ^ At a specific argument of a function, indexed by its
+                      -- position.
+  | InstDoc Type      -- ^ At a class or family instance.
+  deriving ( Show, Eq, Ord, Data, Generic )
+
 -----------------------------------------------------
 --              Internal helper functions
 -----------------------------------------------------
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 6d6e06b8ce..0a570a89ee 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -1,5 +1,13 @@
 # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
 
+## 2.18.0.0
+  * Add `putDoc` and `getDoc` which allow Haddock documentation to be attached
+    to module headers, declarations, function arguments and instances, as well
+    as queried. These are quite low level operations, so for convenience there
+    are several combinators that can be used with `Dec`s directly, including
+    `withDecDoc`/`withDecsDoc` as well as `_doc` counterparts to many of the
+    `Dec` helper functions.
+
 ## 2.17.0.0
   * Typed Quotations now return a value of type `Code m a` (GHC Proposal #195).
     The main motiviation is to make writing instances easier and make it easier to
diff --git a/testsuite/tests/showIface/DocsInHiFileTH.hs b/testsuite/tests/showIface/DocsInHiFileTH.hs
new file mode 100644
index 0000000000..73b46c8876
--- /dev/null
+++ b/testsuite/tests/showIface/DocsInHiFileTH.hs
@@ -0,0 +1,218 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeFamilies, DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses, StandaloneKindSignatures, PolyKinds #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+-- |This is the module header
+module DocInHiFilesTH where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import DocsInHiFileTHExternal
+
+f :: Int
+f = 42
+
+$(putDoc (DeclDoc 'f) "The meaning of life" >> pure [])
+
+-- |A data type
+data Foo =
+    -- |A constructor
+    Foo
+
+do
+  Just "A data type" <- getDoc (DeclDoc ''Foo)
+  Just "A constructor" <- getDoc (DeclDoc 'Foo)
+  putDoc (DeclDoc ''Foo) "A new data type"
+  putDoc (DeclDoc 'Foo) "A new constructor"
+  Just "A new data type" <- getDoc (DeclDoc ''Foo)
+  Just "A new constructor" <- getDoc (DeclDoc 'Foo)
+  pure []
+
+-- |Some documentation
+g :: String
+g = "Hello world"
+
+do
+  Just "Some documentation" <- getDoc (DeclDoc 'g)
+  pure []
+
+-- Testing module headers
+
+do
+  Just "This is the module header" <- getDoc ModuleDoc
+  putDoc ModuleDoc "This is the new module header"
+  Just "This is the new module header" <- getDoc ModuleDoc
+  pure []
+
+-- Testing argument documentation
+
+h :: Int -- ^Your favourite number
+  -> Bool -- ^Your favourite element in the Boolean algebra
+  -> String -- ^A return value
+h _ _ = "Hello world"
+
+do
+  Just "Your favourite number" <- getDoc (ArgDoc 'h 0)
+  Just "Your favourite element in the Boolean algebra" <- getDoc (ArgDoc 'h 1)
+  Just "A return value" <- getDoc (ArgDoc 'h 2)
+  Nothing <- getDoc (ArgDoc 'h 3)
+  putDoc (ArgDoc 'h 1) "Your least favourite Boolean"
+  Just "Your least favourite Boolean" <- getDoc (ArgDoc 'h 1)
+  pure []
+
+
+-- Testing classes and instances
+
+-- |A fancy class
+class C a where
+
+-- |A fancy instance
+instance C Int where
+instance C String where
+
+class D a where
+-- |Another fancy instance
+instance D a where
+
+-- |A type family
+type family E a
+
+-- |A type family instance
+type instance E Bool = Int
+
+i :: E Bool
+i = 42
+
+do
+  Just "A fancy class" <- getDoc (DeclDoc ''C)
+  Just "A fancy instance" <- getDoc . InstDoc =<< [t| C Int |]
+  Just "Another fancy instance" <- getDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "a"))))
+  Just "Another fancy instance" <- getDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "b"))))
+  Nothing <- getDoc . InstDoc =<< [t| C String |]
+
+  putDoc (DeclDoc ''C) "A new class"
+  putDoc (InstDoc (AppT (ConT ''C) (ConT ''Int))) "A new instance"
+  putDoc (InstDoc (AppT (ConT ''C) (ConT ''String))) "Another new instance"
+  putDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "a")))) "Another new instance"
+  Just "A new class" <- getDoc (DeclDoc ''C)
+  Just "A new instance" <- getDoc . InstDoc =<< [t| C Int |]
+  Just "Another new instance" <- getDoc . InstDoc =<< [t| C String |]
+  Just "Another new instance" <- getDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "a"))))
+
+  Just "A type family" <- getDoc (DeclDoc ''E)
+  -- Doesn't work just yet. See T18241
+  -- https://gitlab.haskell.org/ghc/ghc/issues/18241
+  Just "A type family instance" <- getDoc . InstDoc =<< [t| E Bool |]
+
+  pure []
+
+-- Testing documentation from external modules
+do
+  Just "This is an external function" <- getDoc (DeclDoc 'externalFunc)
+  Just "Some integer" <- getDoc (ArgDoc 'externalFunc 0)
+
+  Just "This is an external class" <- getDoc (DeclDoc ''ExternalClass)
+  Just "This is an external instance" <-
+    getDoc . InstDoc =<< [t| ExternalClass Int |]
+
+  pure []
+
+data family WD11 a
+type family WD13 a
+
+wd8 = ()
+
+class F
+
+-- Testing combinators
+
+withDecsDoc "1" [d| wd1 x = () |]
+withDecsDoc "2" [d| wd2 = () |]
+withDecsDoc "3" [d| data WD3 = WD3 |]
+withDecsDoc "4" [d| newtype WD4 = WD4 () |]
+withDecsDoc "5" [d| type WD5 = () |]
+withDecsDoc "6" [d| class WD6 a where |]
+withDecsDoc "7" [d| instance C Foo where |]
+do
+  d <- withDecDoc "8" $ sigD 'wd8 [t| () |]
+  pure [d]
+--  this gives 'Illegal variable name: ‘WD9’' when splicing
+--  withDoc "9"  [sigD ''WD9 [t| Type -> Type |]]
+withDecsDoc "10" [d| data family WD10 a|]
+withDecsDoc "11" [d| data instance WD11 Foo = WD11Foo |]
+withDecsDoc "12" [d| type family WD12 a |]
+withDecsDoc "13" [d| type instance WD13 Foo = Int |]
+
+--  testing nullary classes here
+withDecsDoc "14" [d| instance F |]
+
+withDecsDoc "15" [d| foreign import ccall "math.h sin" sin :: Double -> Double |]
+-- this gives 'Foreign export not (yet) handled by Template Haskell'
+-- withDecsDoc "16" [d| foreign export ccall "addInt" (+) :: Int -> Int -> Int |]
+
+wd17 = 42
+
+do
+  d <- withDecDoc "17" (sigD 'wd17 [t| Int |])
+  pure [d]
+
+do
+  let nm = mkName "wd18"
+  d' <- withDecDoc "18" $ sigD nm [t| Int |]
+  d <-  withDecDoc "19" $ valD (varP nm) (normalB [| 42 |]) []
+  pure [d, d']
+
+-- Doing this to test that wd20 is documented as "20" and not "2020"
+withDecsDoc "20" [d|
+  wd20 :: Int
+  wd20 = 42
+  |]
+
+do
+  let defBang = bang noSourceUnpackedness noSourceStrictness
+  patSynVarName <- newName "a"
+  sequenceA
+    [ funD_doc (mkName "qux") [clause [ [p| a |], [p| b |] ] (normalB [e| () |]) []]
+        (Just "This is qux") [Just "Arg uno", Just "Arg dos"]
+
+    , dataD_doc (cxt []) (mkName "Quux") [] Nothing
+        [ ( normalC (mkName "Quux1") [bangType defBang (reifyType ''Int)]
+          , Just "This is Quux1",  [Just "I am an integer"])
+        , ( normalC (mkName "Quux2")
+              [ bangType defBang (reifyType ''String)
+              , bangType defBang (reifyType ''Bool)
+              ]
+          , Just "This is Quux2", map Just ["I am a string", "I am a bool"])
+        ] [] (Just "This is Quux")
+
+    , dataD_doc (cxt []) (mkName "Quuz") [] Nothing
+        [ ( recC (mkName "Quuz") [varBangType (mkName "quuz1_a") (bangType defBang (reifyType ''String))]
+        , Just "This is a record constructor", [Just "This is the record constructor's argument"])
+        ] [] (Just "This is a record type")
+
+    , newtypeD_doc (cxt []) (mkName "Corge") [] Nothing
+        ( recC (mkName ("Corge")) [varBangType (mkName "runCorge") (bangType defBang [t| Int |])]
+        , Just "This is a newtype record constructor", [Just "This is the newtype record constructor's argument"]
+        ) [] (Just "This is a record newtype")
+
+    , dataInstD_doc (cxt []) Nothing [t| WD11 Int |] Nothing
+        [ ( normalC (mkName "WD11Int") [bangType defBang [t| Int |]]
+        , Just "This is a data instance constructor", [Just "This is a data instance constructor argument"])
+        ] [] (Just "This is a data instance")
+
+    , newtypeInstD_doc (cxt []) Nothing [t| WD11 Bool |] Nothing
+        (normalC (mkName "WD11Bool") [bangType defBang [t| Bool |]]
+        , Just "This is a newtype instance constructor", [Just "This is a newtype instance constructor argument"])
+        [] (Just "This is a newtype instance")
+
+    , patSynD_doc (mkName "Tup2") (prefixPatSyn [patSynVarName]) unidir
+        [p| ($(varP patSynVarName), $(varP patSynVarName)) |]
+        (Just "Matches a tuple of (a, a)") [Just "The thing to match twice"]
+
+    , withDecDoc "My cool class" $ do
+        tyVar <- newName "a"
+        classD (cxt []) (mkName "Pretty") [plainTV tyVar] []
+          [ withDecDoc "Prettily prints the object" $
+              sigD (mkName "prettyPrint") [t| $(varT tyVar) -> String |]
+          ]
+    ]
diff --git a/testsuite/tests/showIface/DocsInHiFileTH.stdout b/testsuite/tests/showIface/DocsInHiFileTH.stdout
new file mode 100644
index 0000000000..6951b9a1e5
--- /dev/null
+++ b/testsuite/tests/showIface/DocsInHiFileTH.stdout
@@ -0,0 +1,118 @@
+module header:
+  Just "This is the new module header"
+declaration docs:
+  Tup2:
+    "Matches a tuple of (a, a)"
+  f:
+    "The meaning of life"
+  g:
+    "Some documentation"
+  qux:
+    "This is qux"
+  sin:
+    "15"
+  wd1:
+    "1"
+  wd17:
+    "17"
+  wd18:
+    "18"
+  wd2:
+    "2"
+  wd20:
+    "20"
+  wd8:
+    "8"
+  C:
+    "A new class"
+  Corge:
+    "This is a newtype record constructor"
+  runCorge:
+    "This is the newtype record constructor's argument"
+  E:
+    "A type family"
+  Foo:
+    "A new data type"
+  Foo:
+    "A new constructor"
+  Pretty:
+    "My cool class"
+  prettyPrint:
+    "Prettily prints the object"
+  Quux:
+    "This is Quux"
+  Quux1:
+    "This is Quux1"
+  Quux2:
+    "This is Quux2"
+  Quuz:
+    "This is a record constructor"
+  quuz1_a:
+    "This is the record constructor's argument"
+  WD10:
+    "10"
+  WD11Bool:
+    "This is a newtype instance constructor"
+  WD11Int:
+    "This is a data instance constructor"
+  WD12:
+    "12"
+  WD3:
+    "3"
+  WD4:
+    "4"
+  WD5:
+    "5"
+  WD6:
+    "6"
+  $fCTYPEFoo:
+    "7"
+  $fCTYPEInt:
+    "A new instance"
+  $fCTYPE[]:
+    "Another new instance"
+  $fDka:
+    "Another new instance"
+  $fF:
+    "14"
+  D:R:EBool:
+    "A type family instance"
+  D:R:WD11Bool0:
+    "This is a newtype instance"
+  D:R:WD11Foo0:
+    "11"
+  D:R:WD11Int0:
+    "This is a data instance"
+  D:R:WD13Foo:
+    "13"
+arg docs:
+  Tup2:
+    0:
+      "The thing to match twice"
+  h:
+    0:
+      "Your favourite number"
+    1:
+      "Your least favourite Boolean"
+    2:
+      "A return value"
+  qux:
+    0:
+      "Arg uno"
+    1:
+      "Arg dos"
+  Quux1:
+    0:
+      "I am an integer"
+  Quux2:
+    0:
+      "I am a string"
+    1:
+      "I am a bool"
+  WD11Bool:
+    0:
+      "This is a newtype instance constructor argument"
+  WD11Int:
+    0:
+      "This is a data instance constructor argument"
+extensible fields:
diff --git a/testsuite/tests/showIface/DocsInHiFileTHExternal.hs b/testsuite/tests/showIface/DocsInHiFileTHExternal.hs
new file mode 100644
index 0000000000..9a1d46b05e
--- /dev/null
+++ b/testsuite/tests/showIface/DocsInHiFileTHExternal.hs
@@ -0,0 +1,12 @@
+module DocsInHiFileTHExternal where
+
+-- |This is an external function
+externalFunc :: Int -- ^Some integer
+             -> Int -- ^Another integer
+externalFunc = const 42
+
+-- |This is an external class
+class ExternalClass a where
+
+-- |This is an external instance
+instance ExternalClass Int where
diff --git a/testsuite/tests/showIface/Makefile b/testsuite/tests/showIface/Makefile
index 7eafdfc9d2..c45f38684e 100644
--- a/testsuite/tests/showIface/Makefile
+++ b/testsuite/tests/showIface/Makefile
@@ -13,3 +13,7 @@ DocsInHiFile0:
 DocsInHiFile1:
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFile.hs
 	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 100 'module header:'
+
+DocsInHiFileTH:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFileTHExternal.hs DocsInHiFileTH.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFileTH.hi | grep -A 200 'module header:'
diff --git a/testsuite/tests/showIface/all.T b/testsuite/tests/showIface/all.T
index e2ec264431..a5e5f5f085 100644
--- a/testsuite/tests/showIface/all.T
+++ b/testsuite/tests/showIface/all.T
@@ -6,3 +6,6 @@ test('DocsInHiFile1',
      extra_files(['DocsInHiFile.hs']),
      makefile_test, ['DocsInHiFile1'])
 test('T17871', [extra_files(['T17871a.hs'])], multimod_compile, ['T17871', '-v0'])
+test('DocsInHiFileTH',
+     extra_files(['DocsInHiFileTHExternal.hs', 'DocsInHiFileTH.hs']),
+     makefile_test, ['DocsInHiFileTH'])
diff --git a/testsuite/tests/showIface/should_fail/THPutDocExternal.hs b/testsuite/tests/showIface/should_fail/THPutDocExternal.hs
new file mode 100644
index 0000000000..f9a180af4c
--- /dev/null
+++ b/testsuite/tests/showIface/should_fail/THPutDocExternal.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module THPutDocExternal where
+
+import Language.Haskell.TH
+import THPutDocExternalA
+
+putDoc (DeclDoc 'f) "Hello world" >> pure []
diff --git a/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr b/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr
new file mode 100644
index 0000000000..3063fe9350
--- /dev/null
+++ b/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr
@@ -0,0 +1,2 @@
+THPutDocExternal.hs:8:1:
+    Can't add documentation to THPutDocExternalA.f as it isn't inside the current module
diff --git a/testsuite/tests/showIface/should_fail/THPutDocExternalA.hs b/testsuite/tests/showIface/should_fail/THPutDocExternalA.hs
new file mode 100644
index 0000000000..694266bbe9
--- /dev/null
+++ b/testsuite/tests/showIface/should_fail/THPutDocExternalA.hs
@@ -0,0 +1,4 @@
+module THPutDocExternalA where
+
+f :: Int
+f = 42
diff --git a/testsuite/tests/showIface/should_fail/THPutDocNonExistent.hs b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.hs
new file mode 100644
index 0000000000..d0b1d7a162
--- /dev/null
+++ b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module THPutDocNonExistent where
+
+import Language.Haskell.TH
+
+class A a where
+data B
+
+do
+  t <- [t| A B |]
+  putDoc (InstDoc t) "a"
+  pure []
diff --git a/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr
new file mode 100644
index 0000000000..ce3a64a1d9
--- /dev/null
+++ b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr
@@ -0,0 +1,2 @@
+THPutDocNonExistent.hs:10:1:
+    Couldn't find any instances of THPutDocNonExistent.A THPutDocNonExistent.B to add documentation to
diff --git a/testsuite/tests/showIface/should_fail/all.T b/testsuite/tests/showIface/should_fail/all.T
new file mode 100644
index 0000000000..0dd8106b81
--- /dev/null
+++ b/testsuite/tests/showIface/should_fail/all.T
@@ -0,0 +1,9 @@
+test('THPutDocExternal',
+     normal,
+     multimod_compile_fail,
+     ['THPutDocExternal', '-no-hs-main -haddock -c -v0'])
+
+test('THPutDocNonExistent',
+     normal,
+     multimod_compile_fail,
+     ['THPutDocNonExistent', '-no-hs-main -haddock -c -v0'])
diff --git a/utils/haddock b/utils/haddock
-Subproject d1bf3e5030ebf0f8f7443b394abb96da2f216eb
+Subproject d930bd87cd43d840bf2877e4a51b2a48c2e18f7