1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
From e455bc18e15adf05a1f32bc7c4512eedb7ab889f Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Tue, 8 Dec 2020 19:42:52 +0100
Subject: [PATCH 1/2] 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 +-
.../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(-)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 647812f93..024a6c513 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/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 f80a9c05f..541f40c4f 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/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 ef0ba1b67..30b8d43eb 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/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 0874e7b4d..43fe3e774 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/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 c2cf08bb2..853f4b1b2 100644
--- a/src/Haddock/Types.hs
+++ b/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
From e1fe49e9458a5d5161adc8b5b8bfea6437a9eedf Mon Sep 17 00:00:00 2001
From: alexbiehl <alexbiehl@gmail.com>
Date: Tue, 8 Dec 2020 20:03:49 +0100
Subject: [PATCH 2/2] Import intercalate
---
haddock-api/src/Haddock/Interface/Rename.hs | 1 +
1 file changed, 1 insertion(+)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 78c585814..4d9eadac5 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -29,6 +29,7 @@ import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
import Control.Arrow ( first )
import Control.Monad hiding (mapM)
+import Data.List (intercalate)
import qualified Data.Map as Map hiding ( Map )
import qualified Data.Set as Set
import Prelude hiding (mapM)
|
GitWeb