From bc962c945af2955402c8bed66ccb310f35a1e676 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Tue, 8 Dec 2020 19:42:52 +0100
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            | 29 +++++++++++++++++++++++---
 haddock-api/src/Haddock/Types.hs               |  1 +
 5 files changed, 32 insertions(+), 6 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 647812f9..024a6c51 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -255,7 +255,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 f80a9c05..541f40c4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -407,7 +407,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 ef0ba1b6..30b8d43e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -536,6 +536,8 @@ 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   = tcdNameI decl
+
     hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
 
     -- Associated types
@@ -794,7 +796,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 0874e7b4..43fe3e77 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -58,8 +58,7 @@ moduleString = moduleNameString . moduleName
 isNameSym :: Name -> Bool
 isNameSym = isSymOcc . nameOccName
 
-getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
-                     HsDecl p -> [IdP p]
+getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
 getMainDeclBinder (TyClD _ d) = [tcdName d]
 getMainDeclBinder (ValD _ d) =
   case collectHsBindBinders d of
@@ -221,6 +220,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)
@@ -761,4 +785,3 @@ defaultRuntimeRepVars = go emptyVarEnv
 
     go _ ty@(LitTy {}) = ty
     go _ ty@(CoercionTy {}) = ty
-
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index c2cf08bb..853f4b1b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -789,6 +789,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