Crash when exporting record selectors of data family instances

This fixes bug #294. This also fixes a related but never-before-mentioned bug about the display of GADT record selectors with non-polymorphic type signatures. Note: Associated data type constructors fail to show up if nothing is exported that they could be attached to. Exporting any of the data types in the instance head, or the class + data family itself, causes them to show up, but in the absence of either of these, exporting just the associated data type with the constructor itself will result in it being hidden. The only scenario I can come up that would involve this kind of situation involved OverlappingInstances, and even then it can be mitigated by just exporting the class itself, so I'm not going to solve it since the logic would most likely be very complicated.
author: Niklas Haas <git@nand.wakku.to> 2014-03-31 20:02:36 +0200
committer: Niklas Haas <git@nand.wakku.to> 2014-03-31 20:09:58 +0200
commit: a6e36fc8cde675c2b7b2bc8f519221c93f20f207 (patch)
tree: dda96a33a1be220e83fb810c88b96e1f13aa297e
parent: d6cf6f9c75e08ce1760c2dbdee81775ba97a5f0c (diff)
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.
author	Niklas Haas <git@nand.wakku.to>	2014-03-31 20:02:36 +0200
committer	Niklas Haas <git@nand.wakku.to>	2014-03-31 20:09:58 +0200
commit	a6e36fc8cde675c2b7b2bc8f519221c93f20f207 (patch)
tree	dda96a33a1be220e83fb810c88b96e1f13aa297e
parent	d6cf6f9c75e08ce1760c2dbdee81775ba97a5f0c (diff)