From 1740bdda25e72770fcdd3973862058472486a1a3 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri, 17 Jan 2020 14:34:35 -0500
Subject: Changes for GHC#17566

See https://gitlab.haskell.org/ghc/ghc/merge_requests/2469
---
 haddock-api/src/Haddock/Backends/LaTeX.hs      |  2 +-
 haddock-api/src/Haddock/Backends/Xhtml.hs      |  2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  4 ++--
 haddock-api/src/Haddock/GhcUtils.hs            | 28 ++++++++++++++++++++++++--
 haddock-api/src/Haddock/Types.hs               |  1 +
 5 files changed, 31 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src/Haddock')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 6fd7969f..d29c195f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -250,7 +250,7 @@ declNames :: LHsDecl DocNameI
              , [DocName]       --   names being declared
              )
 declNames (L _ decl) = case decl of
-  TyClD _ d  -> (empty, [tcdName d])
+  TyClD _ d  -> (empty, [tcdNameI d])
   SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
   SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
   ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 9add4cae..9e267150 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -402,7 +402,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d
     exportSubs _ = []
 
     exportName :: ExportItem DocNameI -> [IdP DocNameI]
-    exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)
+    exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl)
     exportName ExportNoDecl { expItemName } = [expItemName]
     exportName _ = []
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a24715a7..dce2366b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -557,7 +557,7 @@ ppClassDecl summary links instances fixities loc d subdocs
     -- Only the fixity relevant to the class header
     fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
 
-    nm   = tcdName decl
+    nm   = tcdNameI decl
 
     hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
 
@@ -779,7 +779,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
   | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit
 
   where
-    docname   = tcdName dataDecl
+    docname   = tcdNameI dataDecl
     curname   = Just $ getName docname
     cons      = dd_cons (tcdDataDefn dataDecl)
     isH98     = case unLoc (head cons) of
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 7350f116..b423d55f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -55,8 +55,7 @@ moduleString = moduleNameString . moduleName
 isNameSym :: Name -> Bool
 isNameSym = isSymOcc . nameOccName
 
-getMainDeclBinder :: XRec pass Pat ~ Located (Pat pass) =>
-                     HsDecl pass -> [IdP pass]
+getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
 getMainDeclBinder (TyClD _ d) = [tcdName d]
 getMainDeclBinder (ValD _ d) =
   case collectHsBindBinders d of
@@ -219,6 +218,31 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
   -- Should only be called on ConDeclGADT
 getGADTConType (XConDecl nec) = noExtCon nec
 
+getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]
+getMainDeclBinderI (TyClD _ d) = [tcdNameI d]
+getMainDeclBinderI (ValD _ d) =
+  case collectHsBindBinders d of
+    []       -> []
+    (name:_) -> [name]
+getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
+getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
+getMainDeclBinderI _ = []
+
+familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName
+familyDeclLNameI (FamilyDecl { fdLName = n }) = n
+familyDeclLNameI (XFamilyDecl nec) = noExtCon nec
+
+tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName
+tyClDeclLNameI (FamDecl { tcdFam = fd })     = familyDeclLNameI fd
+tyClDeclLNameI (SynDecl { tcdLName = ln })   = ln
+tyClDeclLNameI (DataDecl { tcdLName = ln })  = ln
+tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln
+tyClDeclLNameI (XTyClDecl nec) = noExtCon nec
+
+tcdNameI :: TyClDecl DocNameI -> DocName
+tcdNameI = unLoc . tyClDeclLNameI
+
 -- -------------------------------------
 
 getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index b5659038..04b2d4fc 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -741,6 +741,7 @@ type instance XDataDecl     DocNameI = NoExtField
 type instance XSynDecl      DocNameI = NoExtField
 type instance XFamDecl      DocNameI = NoExtField
 type instance XXFamilyDecl  DocNameI = NoExtCon
+type instance XXTyClDecl    DocNameI = NoExtCon
 
 type instance XHsIB             DocNameI _ = NoExtField
 type instance XHsWC             DocNameI _ = NoExtField
-- 
cgit v1.2.3