Change rendering of duplicate record field docs

See Haddock Trac #195. We now change this behaviour to only rendering the documentation attached to the first instance of a duplicate field. Perhaps we could improve this by rendering the first instance that has documentation attached to it but for now, we'll stick with this.

Change rendering of duplicate record field docs
e5bd27b5 · Mateusz Kowalczyk · daa0ae5b · e5bd27b5 · e5bd27b5 · e5bd27b5
Commit e5bd27b5 authored 11 years ago by Mateusz Kowalczyk
--- a/doc/haddock.xml
+++ b/doc/haddock.xml
@@ -1218,6 +1218,29 @@ data R a b =
        Haddock - for example doc comments can appear before or after
        the comma in separated lists such as the list of record fields
        above.</para>
+
+        <para>In case that more than one constructor exports a field
+        with the same name, the documentation attached to the first
+        occurence of the field will be used, even if a comment is not
+        present.
+        </para>
+
+<programlisting>
+data T a = A { someField :: a -- ^ Doc for someField of A
+             }
+         | B { someField :: a -- ^ Doc for someField of B
+             }
+</programlisting>
+
+        <para>In the above example, all occurences of
+        <literal>someField</literal> in the documentation are going to
+        be documented with <literal>Doc for someField of A</literal>.
+        Note that Haddock versions 2.14.0 and before would join up
+        documentation of each field and render the result. The reason
+        for this seemingly weird behaviour is the fact that
+        <literal>someField</literal> is actually the same (partial)
+        function.</para>
+
      </section>

      <section>

--- a/html-test/ref/Bug195.html
+++ b/html-test/ref/Bug195.html
+<!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
+    >Bug195</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_Bug195.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"
+	>Bug195</p
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a name="t:T" class="def"
+	    >T</a
+	    ></p
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a name="v:A" class="def"
+		  >A</a
+		  ></td
+		><td class="doc empty"
+		>&nbsp;</td
+		></tr
+	      ><tr
+	      ><td colspan="2"
+		><div class="subs fields"
+		  ><p class="caption"
+		    >Fields</p
+		    ><dl
+		    ><dt class="src"
+		      ><a name="v:someField" class="def"
+			>someField</a
+			> :: ()</dt
+		      ><dd class="doc"
+		      ><p
+			>Doc for someField of A</p
+			></dd
+		      ><dt class="src"
+		      ><a name="v:someOtherField" class="def"
+			>someOtherField</a
+			> :: ()</dt
+		      ><dd class="doc"
+		      ><p
+			>Doc for someOtherField of A</p
+			></dd
+		      ></dl
+		    ><div class="clear"
+		    ></div
+		    ></div
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		><a name="v:B" class="def"
+		  >B</a
+		  ></td
+		><td class="doc empty"
+		>&nbsp;</td
+		></tr
+	      ><tr
+	      ><td colspan="2"
+		><div class="subs fields"
+		  ><p class="caption"
+		    >Fields</p
+		    ><dl
+		    ><dt class="src"
+		      ><a name="v:someField" class="def"
+			>someField</a
+			> :: ()</dt
+		      ><dd class="doc"
+		      ><p
+			>Doc for someField of A</p
+			></dd
+		      ><dt class="src"
+		      ><a name="v:someOtherField" class="def"
+			>someOtherField</a
+			> :: ()</dt
+		      ><dd class="doc"
+		      ><p
+			>Doc for someOtherField of A</p
+			></dd
+		      ></dl
+		    ><div class="clear"
+		    ></div
+		    ></div
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		><a name="v:C" class="def"
+		  >C</a
+		  ></td
+		><td class="doc empty"
+		>&nbsp;</td
+		></tr
+	      ><tr
+	      ><td colspan="2"
+		><div class="subs fields"
+		  ><p class="caption"
+		    >Fields</p
+		    ><dl
+		    ><dt class="src"
+		      ><a name="v:someField" class="def"
+			>someField</a
+			> :: ()</dt
+		      ><dd class="doc"
+		      ><p
+			>Doc for someField of A</p
+			></dd
+		      ><dt class="src"
+		      ><a name="v:someOtherField" class="def"
+			>someOtherField</a
+			> :: ()</dt
+		      ><dd class="doc"
+		      ><p
+			>Doc for someOtherField of A</p
+			></dd
+		      ></dl
+		    ><div class="clear"
+		    ></div
+		    ></div
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ><p
+      >Produced by <a href=""
+	>Haddock</a
+	> version 2.14.0</p
+      ></div
+    ></body
+  ></html
+>
--- a/html-test/src/Bug195.hs
+++ b/html-test/src/Bug195.hs
+module Bug195 where
+
+data T = A { someField :: () -- ^ Doc for someField of A
+           , someOtherField :: () -- ^ Doc for someOtherField of A
+           }
+       | B { someField :: () -- ^ Doc for someField of B
+           , someOtherField :: () -- ^ Doc for someOtherField of B
+           }
+       | C { someField :: () -- ^ Doc for someField of C
+           , someOtherField :: () -- ^ Doc for someOtherField of C
+           }
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -31,6 +31,7 @@ import Data.Ord
 import Control.Applicative
 import Control.DeepSeq
 import Control.Monad
+import Data.Function (on)
 import qualified Data.Foldable as F
 import qualified Data.Traversable as T

@@ -255,7 +256,7 @@ mkMaps :: DynFlags
       -> ErrMsgM Maps
 mkMaps dflags gre instances decls = do
  (a, b, c, d) <- unzip4 <$> mapM mappings decls
-  return (f a, f b, f c, f d, instanceMap)
+  return (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
  where
    f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
    f = M.fromListWith (<>) . concat