diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs
index 207b65f2fda9ad238f26a339adb5e9417fbf123c..425cc03bf03c98d570603b69866008412d09eeef 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 bf15fd2e1093efbe1a27b9f993ca87e6bc763324..fafcdb6533ca7c2bf315a2a00ad97f62d21ebfc0 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 56f089a7560f7fd891e9ce3277ef24d853775cce..fa278b7983e263d6a49be2f3080356285b43b1d8 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 53f0032f284f4049a871b1e2c49f1f2912e0f8f7..323f69f0d37df0c855674b19b48ff7b368108b91 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 c2626ce6b3d0324905d0f431a75dd06c83c8c0fe..fc2f8b8ab3a0ca1b85e74f33a06adc0d7d66fd32 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 109a4416bc4b2f3c6c9b57d8651d495df4102608..b89f5c8a6cfb04d6477d0a83128ce868fb50a41e 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 7ae4ccb0f62ecd078a663316483b6ad47e0955b1..89ba997d8ad2997983074f0101066f5ea3454f1e 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 9e9e82bca40e853ded6ea7f093c2d33b93829857..81cf5ea40873881c182e7096c6a7e4b2df4843d9 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 0003a9316957ccfa4fc6e28421cc828af51db364..2c9be13dffc822b1ee05ff1cf15eff7881c0c453 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 a3c087c4dae451d99957c8a88a4e24358848f3b4..873c9b9fd2c05220cd1364e724d44ea1c0570f06 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 3b0022fb8a8477e6e711c9e3419c8fa9daa2b981..131f694f6b6893c33727a74843dcad02a09feaff 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 2f0dfcde8d6a099c7caf868bc292a81b3c3025ec..0ac6fe4d9cc2f34d63302b6d322dbac2778431aa 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 d21686a3264a2ccca28bcd50b40e728aa667d406..10182422106cabb2032b25cf29e855bead323135 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 56e38c024457c32c4856e869a8beb7571dd93483..f2325db1e1bb98863e694fee0141c6843100b675 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 69326eb9d10ff9423516e60c532ce5725557828f..236229a9dfe257d816c897f4c53be5110acd4173 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 2da2bd61c6e5b67b74a4b8fb83c1d5e4630bd738..83432c14e3b0c46d5f63f372e6fee8b15d608ee1 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 3e05081619348d84caba66cc744b1ab70593d3a7..de90df2bfde586312efa780d55f69e86e4a94bb9 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 a41d0a47b39d9e459bd14e1f67492363091fa618..706d4a8c6a07b2887ad815007b08f664e2c45237 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 3cb5a44ee82db200971c96f33afa0d2896d2650f..d3c5a5eb45b6de3f266a4b90d682f765d1c06931 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 6d6e06b8ce8d67d41140154fc123455406e92fb2..0a570a89eec33951514a0b99b6eefcc849744205 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 0000000000000000000000000000000000000000..73b46c88766cd8f3705808c56c1f5b90118fee91
--- /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 0000000000000000000000000000000000000000..6951b9a1e5b199fa7e8d6ec0ae05e75b55ff9220
--- /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 0000000000000000000000000000000000000000..9a1d46b05ee83fe56dba346c129615354cca45ef
--- /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 7eafdfc9d27d30ba885a7a1898203e566ac3f63e..c45f38684e35d9dc151b055f1f23f8b3493d948c 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 e2ec264431218c4489153733e62250477903c94f..a5e5f5f0857fd1f413287336d4ff32f206bb96c8 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 0000000000000000000000000000000000000000..f9a180af4cede0162b692c8662b8657f33117a92
--- /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 0000000000000000000000000000000000000000..3063fe935023fce6b382dd94a920b1e6ca93a31a
--- /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 0000000000000000000000000000000000000000..694266bbe9a1ca2c56091afcc080e1d980fc6569
--- /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 0000000000000000000000000000000000000000..d0b1d7a162ae4f3c596af56da3aab85afec7f894
--- /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 0000000000000000000000000000000000000000..ce3a64a1d9624699fb2783c5eef3aca7da23da4e
--- /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 0000000000000000000000000000000000000000..0dd8106b81b5e1fe026950c4587a560600b84d5a
--- /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
index d1bf3e5030ebf0f8f7443b394abb96da2f216eb9..d930bd87cd43d840bf2877e4a51b2a48c2e18f74 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit d1bf3e5030ebf0f8f7443b394abb96da2f216eb9
+Subproject commit d930bd87cd43d840bf2877e4a51b2a48c2e18f74