aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--html-test/ref/Bug294.html165
-rw-r--r--html-test/src/Bug294.hs37
-rw-r--r--src/Haddock/Interface/Create.hs34
3 files changed, 226 insertions, 10 deletions
diff --git a/html-test/ref/Bug294.html b/html-test/ref/Bug294.html
new file mode 100644
index 00000000..ceae2932
--- /dev/null
+++ b/html-test/ref/Bug294.html
@@ -0,0 +1,165 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><title
+ >Bug294</title
+ ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+ /><script src="haddock-util.js" type="text/javascript"
+ ></script
+ ><script type="text/javascript"
+ >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_Bug294.html");};
+//]]>
+</script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href=""
+ >Contents</a
+ ></li
+ ><li
+ ><a href=""
+ >Index</a
+ ></li
+ ></ul
+ ><p class="caption empty"
+ >&nbsp;</p
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe-Inferred</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >Bug294</p
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a name="t:A" class="def"
+ >A</a
+ ></p
+ ><div class="subs instances"
+ ><p id="control.i:A" class="caption collapser" onclick="toggleSection('i:A')"
+ >Instances</p
+ ><div id="section.i:A" class="show"
+ ><table
+ ><tr
+ ><td class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href=""
+ >DP</a
+ > <a href=""
+ >A</a
+ > = <a name="v:ProblemCtor-39-" class="def"
+ >ProblemCtor'</a
+ > <a href=""
+ >A</a
+ ></td
+ ><td class="doc empty"
+ >&nbsp;</td
+ ></tr
+ ><tr
+ ><td class="src"
+ ><span class="keyword"
+ >data</span
+ > TP <a href=""
+ >A</a
+ > = <a name="v:ProblemCtor" class="def"
+ >ProblemCtor</a
+ > <a href=""
+ >A</a
+ ></td
+ ><td class="doc empty"
+ >&nbsp;</td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:problemField" class="def"
+ >problemField</a
+ > :: TO <a href=""
+ >A</a
+ > -&gt; <a href=""
+ >A</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:problemField-39-" class="def"
+ >problemField'</a
+ > :: DO <a href=""
+ >A</a
+ > -&gt; <a href=""
+ >A</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:gadtField" class="def"
+ >gadtField</a
+ > :: GADT <a href=""
+ >A</a
+ > -&gt; <a href=""
+ >A</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data family</span
+ > <a name="t:DP" class="def"
+ >DP</a
+ > t :: *</p
+ ><div class="subs instances"
+ ><p id="control.i:DP" class="caption collapser" onclick="toggleSection('i:DP')"
+ >Instances</p
+ ><div id="section.i:DP" class="show"
+ ><table
+ ><tr
+ ><td class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href=""
+ >DP</a
+ > <a href=""
+ >A</a
+ > = <a name="v:ProblemCtor-39-" class="def"
+ >ProblemCtor'</a
+ > <a href=""
+ >A</a
+ ></td
+ ><td class="doc empty"
+ >&nbsp;</td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ><p
+ >Produced by <a href=""
+ >Haddock</a
+ > version 2.15.0</p
+ ></div
+ ></body
+ ></html
+>
diff --git a/html-test/src/Bug294.hs b/html-test/src/Bug294.hs
new file mode 100644
index 00000000..4f874705
--- /dev/null
+++ b/html-test/src/Bug294.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, GADTs #-}
+-- This tests that we are able to extract record selectors for
+-- associated types when the type itself is not exported. Making this
+-- bug exhibit is very simple: simply mention a record field defined
+-- inside of the associated type anywhere in the export list.
+--
+-- Note: ProblemCtor only shows up when T or A are exported but PolyCtor
+-- only shows up when the class is exported as well, since it's polymorphic.
+module Bug294 ( A, problemField, problemField', gadtField
+ , TP(ProblemCtor), DP(ProblemCtor'), TO'(PolyCtor)) where
+
+data A
+
+class T t where
+ data TO t :: *
+ data TP t :: *
+
+ t :: t
+
+instance T A where
+ data TO A = TA { problemField :: A }
+ data TP A = ProblemCtor A
+
+data family DO t :: *
+data family DP t :: *
+
+data instance DO A = DA { problemField' :: A }
+data instance DP A = ProblemCtor' A
+
+data GADT :: * -> * where
+ Ctor :: { gadtField :: A } -> GADT A
+
+class T' t where
+ data TO' t :: *
+
+instance T' a where
+ data TO' a = PolyCtor
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f1262d9f..fb1038f2 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -767,21 +767,33 @@ extractDecl name mdl decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
- TyClD d | isClassDecl d ->
+ TyClD d@ClassDecl {} ->
let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
isVanillaLSig sig ] -- TODO: document fixity
in case matches of
- [s0] -> let (n, tyvar_names) = name_and_tyvars d
+ [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
L pos sig = extractClassDecl n tyvar_names s0
in L pos (SigD sig)
- _ -> error "internal: extractDecl"
- TyClD d | isDataDecl d ->
- let (n, tyvar_names) = name_and_tyvars d
- L pos sig = extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
- in L pos (SigD sig)
+ _ -> error "internal: extractDecl (ClassDecl)"
+ TyClD d@DataDecl {} ->
+ let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
+ in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
+ InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
+ , dfid_pats = HsWB { hswb_cts = tys }
+ , dfid_defn = defn }) ->
+ SigD <$> extractRecSel name mdl n tys (dd_cons defn)
+ InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
+ let matches = [ d | L _ d <- insts
+ , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
+ , ConDeclField { cd_fld_name = L _ n } <- rec
+ , n == name
+ ]
+ in case matches of
+ [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+ _ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
where
- name_and_tyvars d = (tcdName d, hsLTyVarLocNames (tyClDeclTyVars d))
+ getTyVars = hsLTyVarLocNames . tyClDeclTyVars
toTypeNoLoc :: Located Name -> LHsType Name
@@ -799,7 +811,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
-extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name]
+extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
@@ -810,7 +822,9 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
_ -> extractRecSel nm mdl t tvs rest
where
matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
- data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
+ data_ty
+ | ResTyGADT ty <- con_res con = ty
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
-- | Keep export items with docs.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 19:35:48 +0000