diff options
author | nand <git@nand.wakku.to> | 2014-02-04 22:13:27 +0100 |
---|---|---|
committer | Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> | 2014-02-11 15:48:30 +0000 |
commit | e0718f203f2448ba2029e70d14aed075860b7fac (patch) | |
tree | be0d1a8d69efe1c7114b0740a660dff28939ad69 | |
parent | 860d6504530a163e7483960ca8837eb596e05634 (diff) |
Add support for type/data families
This adds support for type/data families with their respective
instances, as well as closed type families and associated type/data
families.
Signed-off-by: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
-rw-r--r-- | CHANGES | 2 | ||||
-rw-r--r-- | doc/haddock.xml | 12 | ||||
-rw-r--r-- | html-test/ref/TypeFamilies.html | 674 | ||||
-rw-r--r-- | html-test/ref/TypeFamilies2.html | 113 | ||||
-rw-r--r-- | html-test/ref/ocean.css | 19 | ||||
-rw-r--r-- | html-test/src/TypeFamilies.hs | 76 | ||||
-rw-r--r-- | html-test/src/TypeFamilies2.hs | 12 | ||||
-rw-r--r-- | resources/html/Ocean.std-theme/ocean.css | 13 | ||||
-rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 16 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 1 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 42 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Layout.hs | 5 | ||||
-rw-r--r-- | src/Haddock/Convert.hs | 34 | ||||
-rw-r--r-- | src/Haddock/GhcUtils.hs | 11 | ||||
-rw-r--r-- | src/Haddock/Interface/AttachInstances.hs | 57 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 122 | ||||
-rw-r--r-- | src/Haddock/Interface/Rename.hs | 9 | ||||
-rw-r--r-- | src/Haddock/Types.hs | 22 |
18 files changed, 1003 insertions, 237 deletions
@@ -27,6 +27,8 @@ Changes in version 2.14.0 * Properly render License field (#271) + * Print type/data family instances + Changes in version 2.13.2 * Handle HsExplicitListTy in renamer (#213) diff --git a/doc/haddock.xml b/doc/haddock.xml index 7c1ca91c..8eb9ede7 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -1093,11 +1093,19 @@ square x = x * x <para>A <literal>newtype</literal> declaration,</para> </listitem> <listitem> - <para>A <literal>type</literal> declaration, or</para> + <para>A <literal>type</literal> declaration</para> </listitem> <listitem> - <para>A <literal>class</literal> declaration.</para> + <para>A <literal>class</literal> declaration,</para> </listitem> + <listitem> + <para>A <literal>data family</literal> or + <literal>type family</literal> declaration, or</para> + </listitem> + <listitem> + <para>A <literal>data instance</literal> or + <literal>type instance</literal> declaration.</para> + </listitem> </itemizedlist> <para>If the annotation is followed by a different kind of diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html index 27a4564c..bfafc3d0 100644 --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -17,11 +17,11 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");}; ><div id="package-header" ><ul class="links" id="page-menu" ><li - ><a href="" + ><a href="index.html" >Contents</a ></li ><li - ><a href="" + ><a href="doc-index.html" >Index</a ></li ></ul @@ -41,56 +41,90 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");}; ><p class="caption" >TypeFamilies</p ></div + ><div id="description" + ><p class="caption" + >Description</p + ><div class="doc" + ><p + >Doc for: module TypeFamilies</p + ></div + ></div ><div id="synopsis" ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" >Synopsis</p ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" ><li class="src short" ><span class="keyword" + >data</span + > <a href="#t:X" + >X</a + ><ul class="subs" + ><li + >= <a href="#v:X" + >X</a + ></li + ><li + >| <a href="#v:XX" + >XX</a + ></li + ><li + >| <a href="#v:XXX" + >XXX</a + ></li + ></ul + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#t:Y" + >Y</a + ></li + ><li class="src short" + ><span class="keyword" + >class</span + > <a href="#t:Test" + >Test</a + > a</li + ><li class="src short" + ><span class="keyword" >type family</span - > <a href="" - >G</a + > <a href="#t:Foo" + >Foo</a + > a</li + ><li class="src short" + ><span class="keyword" + >data family</span + > <a href="#t:Bat" + >Bat</a > a :: *</li ><li class="src short" ><span class="keyword" >class</span - > <a href="" - >A</a + > <a href="#t:Assoc" + >Assoc</a > a <span class="keyword" >where</span ><ul class="subs" ><li ><span class="keyword" >data</span - > <a href="" - >B</a - > a :: * -> *</li + > <a href="#t:AssocD" + >AssocD</a + > a :: *</li ><li - ><a href="" - >f</a - > :: <a href="" - >B</a - > a <a href="" - >Int</a - ></li + ><span class="keyword" + >type</span + > <a href="#t:AssocT" + >AssocT</a + > a :: *</li ></ul ></li ><li class="src short" ><span class="keyword" >type family</span - > <a href="" - >F</a - > a</li - ><li class="src short" - ><a href="" - >g</a - > :: <a href="" - >B</a - > <a href="" - >Int</a - > <a href="" - >Integer</a - ></li + > <a href="#t:Bar" + >Bar</a + > b</li ></ul ></div ><div id="interface" @@ -99,27 +133,485 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");}; ><div class="top" ><p class="src" ><span class="keyword" + >data</span + > <a name="t:X" class="def" + >X</a + ></p + ><div class="doc" + ><p + >Doc for: data X</p + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:X" class="def" + >X</a + ></td + ><td class="doc" + ><p + >Doc for: X</p + ></td + ></tr + ><tr + ><td class="src" + ><a name="v:XX" class="def" + >XX</a + ></td + ><td class="doc" + ><p + >Doc for: XX</p + ></td + ></tr + ><tr + ><td class="src" + ><a name="v:XXX" class="def" + >XXX</a + ></td + ><td class="doc" + ><p + >Doc for: XXX</p + ></td + ></tr + ></table + ></div + ><div class="subs instances" + ><p id="control.i:X" class="caption collapser" onclick="toggleSection('i:X')" + >Instances</p + ><div id="section.i:X" class="show" + ><table + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Assoc" + >Assoc</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc" + ><p + >Doc for: instance Assoc X</p + ></td + ></tr + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Test" + >Test</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc" + ><p + >Doc for: instance Test X</p + ></td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >data</span + > <a href="TypeFamilies.html#t:AssocD" + >AssocD</a + > <a href="TypeFamilies.html#t:X" + >X</a + > = <a name="v:AssocX" class="def" + >AssocX</a + ></td + ><td class="doc empty" + > </td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies.html#t:AssocT" + >AssocT</a + > <a href="TypeFamilies.html#t:X" + >X</a + > = <a href="TypeFamilies.html#t:Foo" + >Foo</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc empty" + > </td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >data</span + > <a href="TypeFamilies.html#t:Bat" + >Bat</a + > <a href="TypeFamilies.html#t:X" + >X</a + > <ul class="subs" + ><li + >= <a name="v:BatX" class="def" + >BatX</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></li + ><li + >| <a name="v:BatXX" class="def" + >BatXX</a + > { <ul class="subs" + ><li + ><a name="v:aaa" class="def" + >aaa</a + > :: <a href="TypeFamilies.html#t:X" + >X</a + ></li + ><li + ><a name="v:bbb" class="def" + >bbb</a + > :: <a href="TypeFamilies.html#t:Y" + >Y</a + ></li + ></ul + > }</li + ></ul + ></td + ><td class="doc" + ><p + >Doc for: data instance Bat X</p + ></td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies.html#t:Foo" + >Foo</a + > <a href="TypeFamilies.html#t:X" + >X</a + > = <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc" + ><p + >Doc for: type instance Foo X = Y</p + ></td + ></tr + ></table + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a name="t:Y" class="def" + >Y</a + ></p + ><div class="doc" + ><p + >Doc for: data Y</p + ></div + ><div class="subs instances" + ><p id="control.i:Y" class="caption collapser" onclick="toggleSection('i:Y')" + >Instances</p + ><div id="section.i:Y" class="show" + ><table + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Assoc" + >Assoc</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc" + ><p + >Doc for: instance Assoc Y</p + ></td + ></tr + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Test" + >Test</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc" + ><p + >Doc for: instance Test Y</p + ></td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >data</span + > <a href="TypeFamilies.html#t:AssocD" + >AssocD</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + > = <a name="v:AssocY" class="def" + >AssocY</a + ></td + ><td class="doc empty" + > </td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies.html#t:AssocT" + >AssocT</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + > = <a href="TypeFamilies.html#t:Bat" + >Bat</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc empty" + > </td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >data</span + > <a href="TypeFamilies.html#t:Bat" + >Bat</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + > <ul class="subs" + ><li + >= <a name="v:BatY" class="def" + >BatY</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + ></li + ><li + >| <a href="TypeFamilies.html#t:X" + >X</a + > <a name="v::-43-" class="def" + >:+</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></li + ></ul + ></td + ><td class="doc" + ><p + >Doc for: data instance Bat Y</p + ></td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies.html#t:Foo" + >Foo</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + > = <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc" + ><p + >Doc for: type instance Foo Y = X</p + ></td + ></tr + ></table + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a name="t:Test" class="def" + >Test</a + > a</p + ><div class="doc" + ><p + >Doc for: class Test a</p + ></div + ><div class="subs instances" + ><p id="control.i:Test" class="caption collapser" onclick="toggleSection('i:Test')" + >Instances</p + ><div id="section.i:Test" class="show" + ><table + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Test" + >Test</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc" + ><p + >Doc for: instance Test Y</p + ></td + ></tr + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Test" + >Test</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc" + ><p + >Doc for: instance Test X</p + ></td + ></tr + ></table + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" >type family</span - > <a name="t:G" class="def" - >G</a + > <a name="t:Foo" class="def" + >Foo</a + > a</p + ><div class="doc" + ><p + >Doc for: type family Foo a</p + ></div + ><div class="subs instances" + ><p id="control.i:Foo" class="caption collapser" onclick="toggleSection('i:Foo')" + >Instances</p + ><div id="section.i:Foo" class="show" + ><table + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies.html#t:Foo" + >Foo</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + > = <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc" + ><p + >Doc for: type instance Foo Y = X</p + ></td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies.html#t:Foo" + >Foo</a + > <a href="TypeFamilies.html#t:X" + >X</a + > = <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc" + ><p + >Doc for: type instance Foo X = Y</p + ></td + ></tr + ></table + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data family</span + > <a name="t:Bat" class="def" + >Bat</a > a :: *</p ><div class="doc" ><p - >Type family G</p + >Doc for: data family Bat a</p + ></div + ><div class="subs instances" + ><p id="control.i:Bat" class="caption collapser" onclick="toggleSection('i:Bat')" + >Instances</p + ><div id="section.i:Bat" class="show" + ><table + ><tr + ><td class="src" + ><span class="keyword" + >data</span + > <a href="TypeFamilies.html#t:Bat" + >Bat</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + > <ul class="subs" + ><li + >= <a name="v:BatY" class="def" + >BatY</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + ></li + ><li + >| <a href="TypeFamilies.html#t:X" + >X</a + > <a name="v::-43-" class="def" + >:+</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></li + ></ul + ></td + ><td class="doc" + ><p + >Doc for: data instance Bat Y</p + ></td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >data</span + > <a href="TypeFamilies.html#t:Bat" + >Bat</a + > <a href="TypeFamilies.html#t:X" + >X</a + > <ul class="subs" + ><li + >= <a name="v:BatX" class="def" + >BatX</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></li + ><li + >| <a name="v:BatXX" class="def" + >BatXX</a + > { <ul class="subs" + ><li + ><a name="v:aaa" class="def" + >aaa</a + > :: <a href="TypeFamilies.html#t:X" + >X</a + ></li + ><li + ><a name="v:bbb" class="def" + >bbb</a + > :: <a href="TypeFamilies.html#t:Y" + >Y</a + ></li + ></ul + > }</li + ></ul + ></td + ><td class="doc" + ><p + >Doc for: data instance Bat X</p + ></td + ></tr + ></table + ></div ></div ></div ><div class="top" ><p class="src" ><span class="keyword" >class</span - > <a name="t:A" class="def" - >A</a - > a <span class="keyword" - >where</span - ></p + > <a name="t:Assoc" class="def" + >Assoc</a + > a</p ><div class="doc" ><p - >A class with an associated type</p + >Doc for: class Assoc a</p ></div ><div class="subs associated-types" ><p class="caption" @@ -127,44 +619,52 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");}; ><p class="src" ><span class="keyword" >data</span - > <a name="t:B" class="def" - >B</a - > a :: * -> *</p + > <a name="t:AssocD" class="def" + >AssocD</a + > a :: *</p ><div class="doc" ><p - >An associated type</p + >Doc for: data AssocD a</p ></div - ></div - ><div class="subs methods" - ><p class="caption" - >Methods</p ><p class="src" - ><a name="v:f" class="def" - >f</a - > :: <a href="" - >B</a - > a <a href="" - >Int</a - ></p + ><span class="keyword" + >type</span + > <a name="t:AssocT" class="def" + >AssocT</a + > a :: *</p ><div class="doc" ><p - >A method</p + >Doc for: type AssocT a</p ></div ></div ><div class="subs instances" - ><p id="control.i:A" class="caption collapser" onclick="toggleSection('i:A')" + ><p id="control.i:Assoc" class="caption collapser" onclick="toggleSection('i:Assoc')" >Instances</p - ><div id="section.i:A" class="show" + ><div id="section.i:Assoc" class="show" ><table ><tr ><td class="src" - ><a href="" - >A</a - > <a href="" - >Int</a + ><a href="TypeFamilies.html#t:Assoc" + >Assoc</a + > <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc" + ><p + >Doc for: instance Assoc Y</p + ></td + ></tr + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Assoc" + >Assoc</a + > <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc" + ><p + >Doc for: instance Assoc X</p ></td - ><td class="doc empty" - > </td ></tr ></table ></div @@ -174,31 +674,47 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");}; ><p class="src" ><span class="keyword" >type family</span - > <a name="t:F" class="def" - >F</a - > a</p + > <a name="t:Bar" class="def" + >Bar</a + > b</p ><div class="doc" ><p - >Doc for family</p + >Doc for: type family Bar b</p + ></div + ><div class="subs equations" + ><p class="caption" + >Equations</p + ><table + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Bar" + >Bar</a + > <a href="TypeFamilies.html#t:X" + >X</a + > = <a href="TypeFamilies.html#t:X" + >X</a + ></td + ><td class="doc empty" + > </td + ></tr + ><tr + ><td class="src" + ><a href="TypeFamilies.html#t:Bar" + >Bar</a + > y = <a href="TypeFamilies.html#t:Y" + >Y</a + ></td + ><td class="doc empty" + > </td + ></tr + ></table ></div - ></div - ><div class="top" - ><p class="src" - ><a name="v:g" class="def" - >g</a - > :: <a href="" - >B</a - > <a href="" - >Int</a - > <a href="" - >Integer</a - ></p ></div ></div ></div ><div id="footer" ><p - >Produced by <a href="" + >Produced by <a href="http://www.haskell.org/haddock/" >Haddock</a > version 2.14.0</p ></div diff --git a/html-test/ref/TypeFamilies2.html b/html-test/ref/TypeFamilies2.html new file mode 100644 index 00000000..eaa0772f --- /dev/null +++ b/html-test/ref/TypeFamilies2.html @@ -0,0 +1,113 @@ +<!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 + >TypeFamilies2</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_TypeFamilies2.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="index.html" + >Contents</a + ></li + ><li + ><a href="doc-index.html" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </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" + >TypeFamilies2</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a name="t:X" class="def" + >X</a + ></p + ><div class="subs instances" + ><p id="control.i:X" class="caption collapser" onclick="toggleSection('i:X')" + >Instances</p + ><div id="section.i:X" class="show" + ><table + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies2.html#t:Foo" + >Foo</a + > <a href="TypeFamilies2.html#t:X" + >X</a + > = Y</td + ><td class="doc empty" + > </td + ></tr + ></table + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >type family</span + > <a name="t:Foo" class="def" + >Foo</a + > a</p + ><div class="subs instances" + ><p id="control.i:Foo" class="caption collapser" onclick="toggleSection('i:Foo')" + >Instances</p + ><div id="section.i:Foo" class="show" + ><table + ><tr + ><td class="src" + ><span class="keyword" + >type</span + > <a href="TypeFamilies2.html#t:Foo" + >Foo</a + > <a href="TypeFamilies2.html#t:X" + >X</a + > = Y</td + ><td class="doc empty" + > </td + ></tr + ></table + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="http://www.haskell.org/haddock/" + >Haddock</a + > version 2.14.0</p + ></div + ></body + ></html +> diff --git a/html-test/ref/ocean.css b/html-test/ref/ocean.css index 42238709..05597d79 100644 --- a/html-test/ref/ocean.css +++ b/html-test/ref/ocean.css @@ -420,6 +420,19 @@ div#style-menu-holder { margin: 0; } +.subs ul { + height: 100%; + padding: 0.5em; + margin: 0; +} + +.subs ul, +.subs ul li.src { + list-style: none; + margin-left: 1em; +} + + .top p.src { border-top: 1px solid #ccc; } @@ -457,6 +470,12 @@ div#style-menu-holder { /* @group Auxillary Pages */ + +.extension-list { + list-style-type: none; + margin-left: 0; +} + #mini { margin: 0 auto; padding: 0 1em 1em; diff --git a/html-test/src/TypeFamilies.hs b/html-test/src/TypeFamilies.hs index 561f95fd..725e76a7 100644 --- a/html-test/src/TypeFamilies.hs +++ b/html-test/src/TypeFamilies.hs @@ -1,28 +1,68 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} +-- | Doc for: module TypeFamilies module TypeFamilies where --- | Type family G -type family G a :: * +-- | Doc for: data X +data X + = X -- ^ Doc for: X + | XX -- ^ Doc for: XX + | XXX -- ^ Doc for: XXX --- | A class with an associated type -class A a where - -- | An associated type - data B a :: * -> * - -- | A method - f :: B a Int +-- | Doc for: data Y +data Y --- | Doc for family -type family F a +-- | Doc for: class Test a +class Test a +-- | Doc for: instance Test X +instance Test X +-- | Doc for: instance Test Y +instance Test Y --- | Doc for G Int -type instance G Int = Bool -type instance G Float = Int +-- | Doc for: type family Foo a +type family Foo a +-- | Doc for: type instance Foo X = Y +type instance Foo X = Y +-- | Doc for: type instance Foo Y = X +type instance Foo Y = X -instance A Int where - data B Int x = Con x - f = Con 3 +-- | Doc for: data family Bat a +data family Bat a :: * -g = Con 5 +-- | Doc for: data instance Bat X +data instance Bat X + = BatX X -- ^ Doc for: BatX X + | BatXX { aaa :: X , bbb :: Y } -- ^ Doc for: BatXX { ... } + +-- | Doc for: data instance Bat Y +data instance Bat Y + = BatY Y -- ^ Doc for: BatY Y + | X :+ X -- X :+ X + +-- | Doc for: class Assoc a +class Assoc a where + -- | Doc for: data AssocD a + data AssocD a :: * + -- | Doc for: type AssocT a + type AssocT a :: * + +-- | Doc for: instance Assoc X +instance Assoc X where + -- | Doc for: data AssocD X = AssocX + data AssocD X = AssocX -- ^ Doc for: AssocX + -- | Doc for: type AssocT X = Foo X + type AssocT X = Foo X + +-- | Doc for: instance Assoc Y +instance Assoc Y where + -- | Doc for: data AssocD Y = AssocY + data AssocD Y = AssocY -- ^ Doc for: AssocY + -- | Doc for: type AssocT Y = Bat Y + type AssocT Y = Bat Y + +-- | Doc for: type family Bar b +type family Bar b where + Bar X = X + Bar y = Y diff --git a/html-test/src/TypeFamilies2.hs b/html-test/src/TypeFamilies2.hs new file mode 100644 index 00000000..718e11dc --- /dev/null +++ b/html-test/src/TypeFamilies2.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies #-} +-- This tests what happens if we have unexported types +-- in type instances. The expected behaviour is +-- that we get the instance, Y is not linked and +-- Haddock shows a linking warning. +module TypeFamilies2 (X, Foo) where + +data X +data Y + +type family Foo a +type instance Foo X = Y diff --git a/resources/html/Ocean.std-theme/ocean.css b/resources/html/Ocean.std-theme/ocean.css index b9ad560e..3d81c3ca 100644 --- a/resources/html/Ocean.std-theme/ocean.css +++ b/resources/html/Ocean.std-theme/ocean.css @@ -420,6 +420,19 @@ div#style-menu-holder { margin: 0; } +.subs ul { + height: 100%; + padding: 0.5em; + margin: 0; +} + +.subs ul, +.subs ul li.src { + list-style: none; + margin-left: 1em; +} + + .top p.src { border-top: 1px solid #ccc; } diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 94adc558..2185340b 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -284,7 +284,7 @@ ppDecl :: LHsDecl DocName ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode TyClD d@(DataDecl {}) - -> ppDataDecl instances subdocs loc doc d unicode + -> ppDataDecl instances subdocs loc (Just doc) d unicode TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now -- TyClD d@(TySynonym {}) @@ -560,9 +560,11 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX -ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode -ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode - +ppInstHead unicode (n, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ts unicode +ppInstHead unicode (n, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ts unicode <+> equals <+> ppType unicode rhs +ppInstHead _unicode (_n, _ts, DataInst _dd) = + error "data instances not supported by --latex yet" lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 @@ -577,8 +579,8 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ppDataDecl :: [DocInstance DocName] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> + [(DocName, DocForDecl DocName)] -> SrcSpan -> + Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> LaTeX ppDataDecl instances subdocs _loc doc dataDecl unicode @@ -590,7 +592,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode cons = dd_cons (tcdDataDefn dataDecl) resTy = (con_res . unLoc . head) cons - body = catMaybes [constrBit, documentationToLaTeX doc] + body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 3168c7b0..53b106a2 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -648,6 +648,7 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Qualification -> ExportItem DocName -> Maybe Html +processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _) = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc processExport summary links unicode qual (ExportDecl decl doc subdocs insts) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index acde5a0f..9180c3c3 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -41,7 +41,7 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links instances loc mbDoc d unicode qual TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual @@ -212,9 +212,9 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info Nothing -> noHtml ) -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> +ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Bool -> Qualification -> Html -ppTyFam summary associated links loc doc decl unicode qual +ppTyFam summary associated links instances loc doc decl unicode qual | summary = ppTyFamHeader True associated decl unicode qual | otherwise = header_ +++ docSection qual doc +++ instancesBit @@ -225,16 +225,19 @@ ppTyFam summary associated links loc doc decl unicode qual header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual) instancesBit - | FamilyDecl { fdInfo = ClosedTypeFamily _eqns } <- decl + | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl , not summary - = noHtml -- TODO: print eqns + = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise = ppInstances instances docname unicode qual - -- TODO: get the instances - instances = [] - + -- Individual equation of a closed type family + ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs + , tfie_pats = HsWB { hswb_cts = ts }} + = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual + <+> equals <+> ppType unicode qual (unLoc rhs) + , Nothing, [] ) -------------------------------------------------------------------------------- -- * Associated Types @@ -244,7 +247,7 @@ ppTyFam summary associated links loc doc decl unicode qual ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool -> Qualification -> Html ppAssocType summ links doc (L loc decl) unicode qual = - ppTyFam summ True links loc (fst doc) decl unicode qual + ppTyFam summ True links [] loc (fst doc) decl unicode qual -------------------------------------------------------------------------------- @@ -423,10 +426,14 @@ ppInstances instances baseName unicode qual instName = getOccString $ getName baseName instDecl :: DocInstance DocName -> SubDecl instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) - instHead ([], n, ts) = ppAppNameTypes n ts unicode qual - instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode qual + instHead (n, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ts unicode qual - + instHead (n, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ts unicode qual + <+> equals <+> ppType unicode qual rhs + instHead (n, ts, DataInst dd) = keyword "data" + <+> ppAppNameTypes n ts unicode qual + <+> ppShortDataDecl False True dd unicode qual lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n @@ -438,9 +445,8 @@ lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -- TODO: print contexts -ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool - -> Qualification -> Html -ppShortDataDecl summary _links _loc dataDecl unicode qual +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html +ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader @@ -455,7 +461,9 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual +++ shortSubDecls (map doGADTConstr cons) where - dataHeader = ppDataHeader summary dataDecl unicode qual + dataHeader + | dataInst = noHtml + | otherwise = ppDataHeader summary dataDecl unicode qual doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual @@ -469,7 +477,7 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> Qualification -> Html ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual - | summary = ppShortDataDecl summary links loc dataDecl unicode qual + | summary = ppShortDataDecl summary False dataDecl unicode qual | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit where diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index 4584fd82..dbc043be 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout ( subArguments, subAssociatedTypes, subConstructors, + subEquations, subFields, subInstances, subMethods, @@ -165,6 +166,10 @@ subFields :: Qualification -> [SubDecl] -> Html subFields qual = divSubDecls "fields" "Fields" . subDlist qual +subEquations :: Qualification -> [SubDecl] -> Html +subEquations qual = divSubDecls "equations" "Equations" . subTable qual + + subInstances :: Qualification -> String -> [SubDecl] -> Html subInstances qual nm = maybe noHtml wrap . instTable where diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 66497783..d9bb0fcf 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -30,6 +30,7 @@ import CoAxiom import ConLike import DataCon import PatSyn +import FamInstEnv import BasicTypes ( TupleSort(..) ) import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon ) @@ -38,6 +39,7 @@ import Bag ( emptyBag ) import Unique ( getUnique ) import SrcLoc ( Located, noLoc, unLoc ) import Data.List( partition ) +import Haddock.Types -- the main function here! yay! @@ -62,7 +64,7 @@ tyThingToLHsDecl t = noLoc $ case t of extractFamilyDecl _ = error "tyThingToLHsDecl: impossible associated tycon" - atTyClDecls = [synifyTyCon at_tc | (at_tc, _) <- classATItems cl] + atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl] atFamDecls = map extractFamilyDecl atTyClDecls in TyClD $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) @@ -80,7 +82,7 @@ tyThingToLHsDecl t = noLoc $ case t of , tcdDocs = [] --we don't have any docs at this point , tcdFVs = placeHolderNames } | otherwise - -> TyClD (synifyTyCon tc) + -> TyClD (synifyTyCon Nothing tc) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) @@ -119,13 +121,13 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | Just ax' <- isClosedSynFamilyTyCon_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = TyClD (synifyTyCon tc) + = TyClD (synifyTyCon (Just ax) tc) | otherwise = error "synifyAxiom: closed/open family confusion" -synifyTyCon :: TyCon -> TyClDecl Name -synifyTyCon tc +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name +synifyTyCon coax tc | isFunTyCon tc || isPrimTyCon tc = DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: @@ -181,7 +183,10 @@ synifyTyCon tc let alg_nd = if isNewTyCon tc then NewType else DataType alg_ctx = synifyCtx (tyConStupidTheta tc) - name = synifyName tc + name = case coax of + Just a -> synifyName a -- Data families are named according to their + -- CoAxioms, not their TyCons + _ -> synifyName tc tyvars = synifyTyVars (tyConTyVars tc) kindSig = Just (tyConKind tc) -- The data constructors. @@ -365,10 +370,19 @@ synifyTyLit (StrTyLit s) = HsStrTy s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> - ([HsType Name], Name, [HsType Name]) +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name synifyInstHead (_, preds, cls, ts) = - ( map (unLoc . synifyType WithinType) preds - , getName cls + ( getName cls , map (unLoc . synifyType WithinType) ts + , ClassInst $ map (unLoc . synifyType WithinType) preds + ) + +-- Convert a family instance, this could be a type family or data family +synifyFamInst :: FamInst -> InstHead Name +synifyFamInst fi = + ( fi_fam fi + , map (unLoc . synifyType WithinType) $ fi_tys fi + , case fi_flavor fi of + SynFamilyInst -> TypeInst . unLoc . synifyType WithinType $ fi_rhs fi + DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c ) diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index a8a4f1c9..bf6436d1 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -91,6 +91,17 @@ getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +getInstLoc :: InstDecl name -> SrcSpan +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l +getInstLoc (TyFamInstD (TyFamInstDecl + -- Since CoAxioms' Names refer to the whole line for type family instances + -- in particular, we need to dig a bit deeper to pull out the entire + -- equation. This does not happen for data family instances, for some reason. + { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index 03d463cb..a56759a5 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -23,6 +23,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Class +import FamInstEnv import FastString import GHC import GhcMonad (withSession) @@ -64,16 +65,17 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = export { expItemInstances = case mb_info of - Just (_, _, cls_instances, _fam_instances) -> -{- - let insts = map (first synifyInstHead) $ sortImage (first instHead) - [ (instanceSig i, getName i) | i <- instances ] --} - let insts = map (first synifyInstHead) $ sortImage (first instHead) $ - filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys) - [ (instanceHead' i, getName i) | i <- cls_instances ] - in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap) - | (inst, name) <- insts ] + Just (_, _, cls_instances, fam_instances) -> + let fam_insts = [ (synifyFamInst i, n) + | i <- sortImage instFam fam_instances + , let n = lookupInstDoc (getName i) iface ifaceMap instIfaceMap + ] + cls_insts = [ (synifyInstHead i, lookupInstDoc n iface ifaceMap instIfaceMap) + | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] + , (i@(_,_,cls,tys), n) <- sortImage (first instHead) is + , not $ isInstanceHidden expInfo cls tys + ] + in cls_insts ++ fam_insts Nothing -> [] } return export' @@ -139,22 +141,27 @@ data SimpleType = SimpleType Name [SimpleType] instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args) - where - argCount (AppTy t _) = argCount t + 1 - argCount (TyConApp _ ts) = length ts - argCount (FunTy _ _ ) = 2 - argCount (ForAllTy _ t) = argCount t - argCount _ = 0 - - simplify (ForAllTy _ t) = simplify t - simplify (FunTy t1 t2) = - SimpleType funTyConName [simplify t1, simplify t2] - simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) - where (SimpleType s ts) = simplify t1 - simplify (TyVarTy v) = SimpleType (tyVarName v) [] - simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) - simplify (LitTy l) = SimpleTyLit l +argCount :: Type -> Int +argCount (AppTy t _) = argCount t + 1 +argCount (TyConApp _ ts) = length ts +argCount (FunTy _ _ ) = 2 +argCount (ForAllTy _ t) = argCount t +argCount _ = 0 + +simplify :: Type -> SimpleType +simplify (ForAllTy _ t) = simplify t +simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) + where (SimpleType s ts) = simplify t1 +simplify (TyVarTy v) = SimpleType (tyVarName v) [] +simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (LitTy l) = SimpleTyLit l + +-- Used for sorting +instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) +instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } + = (map argCount ts, n, map simplify ts, argCount t, simplify t) -- sortImage f = sortBy (\x y -> compare (f x) (f y)) sortImage :: Ord b => (a -> b) -> [a] -> [a] diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 6e85ad16..cf5a3451 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -58,9 +58,10 @@ createInterface tm flags modMap instIfaceMap = do mdl = ms_mod ms dflags = ms_hspp_opts ms !instances = modInfoInstances mi + !fam_instances = md_fam_insts md !exportedNames = modInfoExports mi - (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm + (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. @@ -80,9 +81,10 @@ createInterface tm flags modMap instIfaceMap = do let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom mdl . getName) instances + localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances + ++ map getName fam_instances - maps@(!docMap, !argMap, !subMap, !declMap) <- + maps@(!docMap, !argMap, !subMap, !declMap, _) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs let exports0 = fmap (reverse . map unLoc) mayExports @@ -90,16 +92,14 @@ createInterface tm flags modMap instIfaceMap = do | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls dflags mdl decls - warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports - instances instIfaceMap dflags + instIfaceMap dflags - let !visibleNames = mkVisibleNames exportItems opts + let !visibleNames = mkVisibleNames maps exportItems opts -- Measure haddock documentation coverage. let prunedExportItems0 = pruneExportItems exportItems @@ -138,6 +138,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceSubMap = subMap , ifaceModuleAliases = aliases , ifaceInstances = instances + , ifaceFamInstances = fam_instances , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap } @@ -242,33 +243,33 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) +type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. mkMaps :: DynFlags -> GlobalRdrEnv - -> [ClsInst] + -> [Name] -> [(LHsDecl Name, [HsDocString])] -> 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) + return (f a, f b, f c, f d, instanceMap) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat mappings (ldecl, docStrs) = do - let decl = unLoc ldecl + let L l decl = ldecl let declDoc strs m = do doc <- processDocStrings dflags gre strs m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m return (doc, m') (doc, args) <- declDoc docStrs (typeDocs decl) - let subs = subordinates decl + let subs = subordinates instanceMap decl (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs - let ns = names decl + let ns = names l decl subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs @@ -282,11 +283,14 @@ mkMaps dflags gre instances decls = do return (dm, am, sm, cm) instanceMap :: Map SrcSpan Name - instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] + instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - names :: HsDecl Name -> [Name] - names (InstD (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ }))) = maybeToList (M.lookup l instanceMap) -- See note [2]. - names decl = getMainDeclBinder decl + names :: SrcSpan -> HsDecl Name -> [Name] + names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + where loc = case d of + TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs + _ -> getInstLoc d + names _ decl = getMainDeclBinder decl -- Note [2]: ------------ @@ -303,24 +307,29 @@ mkMaps dflags gre instances decls = do -- | Get all subordinate declarations inside a declaration, and their docs. -subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] -subordinates (TyClD decl) - | isClassDecl decl = classSubs - | isDataDecl decl = dataSubs +subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates instMap decl = case decl of + InstD (ClsInstD d) -> do + DataFamInstDecl { dfid_tycon = L l _ + , dfid_defn = def } <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def + + InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + TyClD d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] where - classSubs = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls decl - , name <- getMainDeclBinder d, not (isValD d) - ] - dataSubs = constrs ++ fields + classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + dataSubs dd = constrs ++ fields where - cons = map unL $ (dd_cons (tcdDataDefn decl)) + cons = map unL $ (dd_cons dd) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons , ConDeclField n _ doc <- flds ] -subordinates _ = [] - -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString @@ -390,38 +399,6 @@ sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) -warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM () -warnAboutFilteredDecls dflags mdl decls = do - let modStr = moduleString mdl - let typeInstances = - nub (concat [[ unLoc (tfie_tycon (unLoc eqn)) - | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn }))) <- decls ], - [ unLoc (dfid_tycon d) - | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ], - [ unLoc tc - | L _ (TyClD (FamDecl (FamilyDecl { fdInfo = ClosedTypeFamily _ - , fdLName = tc }))) <- decls ]]) - - unless (null typeInstances) $ - tell [ - "Warning: " ++ modStr ++ ": Instances of type and data " - ++ "families and equations of closed type families are not yet supported." - ++ "Instances of the following families " - ++ "will be filtered out:\n " ++ (intercalate ", " - $ map (occNameString . nameOccName) typeInstances) ] - - let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD (ClsInstDecl - { cid_poly_ty = i - , cid_tyfam_insts = ats - , cid_datafam_insts = adts }))) <- decls - , not (null ats) || not (null adts) ] - - unless (null instances) $ - tell [ - "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " - ++ "These instances are affected:\n" ++ intercalate ", " instances ] - - -------------------------------------------------------------------------------- -- Filtering of declarations -- @@ -493,20 +470,16 @@ mkExportItems -> [LHsDecl Name] -> Maps -> Maybe [IE Name] - -> [ClsInst] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod warnings gre exportedNames decls0 - (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = + modMap thisMod warnings gre exportedNames decls + (maps@(docMap, argMap, subMap, declMap, instMap)) optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps decls Just exports -> liftM concat $ mapM lookupExport exports where - decls = filter (not . isInstD . unLoc) decls0 - - lookupExport (IEVar x) = declWith x lookupExport (IEThingAbs t) = declWith t lookupExport (IEThingAll t) = declWith t @@ -585,7 +558,7 @@ mkExportItems Nothing -> do liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] - let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] + let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] @@ -710,7 +683,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- A type signature can have multiple names, like: @@ -739,6 +712,10 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = let (doc, _) = lookupDocs name warnings docMap argMap subMap in fmap Just (hiValExportItem dflags name doc) | otherwise = return Nothing + mkExportItem decl@(L _ (InstD d)) + | Just name <- M.lookup (getInstLoc d) instMap = + let (doc, subs) = lookupDocs name warnings docMap argMap subMap in + return $ Just (ExportDecl decl doc subs []) mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = let (doc, subs) = lookupDocs name warnings docMap argMap subMap in @@ -809,14 +786,17 @@ pruneExportItems = filter hasDoc hasDoc _ = True -mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name] -mkVisibleNames exports opts +mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns where - exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs + exportName e@ExportDecl {} = name ++ subs where subs = map fst (expItemSubDocs e) + name = case unLoc $ expItemDecl e of + InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index b4a7e19a..de23e9b5 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -258,11 +258,14 @@ renameLContext (L loc context) = do renameInstHead :: InstHead Name -> RnM (InstHead DocName) -renameInstHead (preds, className, types) = do - preds' <- mapM renameType preds +renameInstHead (className, types, rest) = do className' <- rename className types' <- mapM renameType types - return (preds', className', types') + rest' <- case rest of + ClassInst cs -> ClassInst <$> mapM renameType cs + TypeInst ts -> TypeInst <$> renameType ts + DataInst dd -> DataInst <$> renameTyClD dd + return (className', types', rest') renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 0a633ec0..0e7f83af 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -23,7 +23,7 @@ module Haddock.Types ( import Data.Foldable import Data.Traversable import Control.Exception -import Control.Arrow +import Control.Arrow hiding ((<+>)) import Control.DeepSeq import Data.Typeable import Data.Map (Map) @@ -31,6 +31,7 @@ import qualified Data.Map as Map import GHC hiding (NoLink) import DynFlags (ExtensionFlag, Language) import OccName +import Outputable import Control.Applicative (Applicative(..)) import Control.Monad (ap) @@ -45,6 +46,7 @@ type DocMap a = Map Name (Doc a) type ArgMap a = Map Name (Map Int (Doc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] +type InstMap = Map SrcSpan Name type SrcMap = Map PackageId FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -112,6 +114,7 @@ data Interface = Interface -- | Instances exported by the module. , ifaceInstances :: ![ClsInst] + , ifaceFamInstances :: ![FamInst] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. @@ -273,14 +276,23 @@ instance NamedThing DocName where -- * Instances ----------------------------------------------------------------------------- +-- | The three types of instances +data InstType name + = ClassInst [HsType name] -- ^ Context + | TypeInst (HsType name) -- ^ Body (right-hand side) + | DataInst (TyClDecl name) -- ^ Data constructors + +instance OutputableBndr a => Outputable (InstType a) where + ppr (ClassInst a) = text "ClassInst" <+> ppr a + ppr (TypeInst a) = text "TypeInst" <+> ppr a + ppr (DataInst a) = text "DataInst" <+> ppr a -- | An instance head that may have documentation. type DocInstance name = (InstHead name, Maybe (Doc name)) - --- | The head of an instance. Consists of a context, a class name and a list --- of instance types. -type InstHead name = ([HsType name], name, [HsType name]) +-- | The head of an instance. Consists of a class name, a list of parameters +-- and an instance type +type InstHead name = (name, [HsType name], InstType name) ----------------------------------------------------------------------------- -- * Documentation comments |