From 7dd0a79cce7c4c048e7c145c9f378da3a96392d0 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Sun, 23 Dec 2018 10:23:20 -0500
Subject: Properly synify and render promoted type variables  (#985)

* Synify and render properly promoted type variables

Fixes #923.

* Accept output
---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |   7 +-
 haddock-api/src/Haddock/Convert.hs             |   3 +-
 html-test/ref/Bug548.html                      |  40 ++---
 html-test/ref/Bug923.html                      | 200 +++++++++++++++++++++++++
 html-test/ref/FunArgs.html                     |   2 +-
 html-test/ref/TypeFamilies.html                |  36 ++---
 html-test/src/Bug923.hs                        |  11 ++
 7 files changed, 256 insertions(+), 43 deletions(-)
 create mode 100644 html-test/ref/Bug923.html
 create mode 100644 html-test/src/Bug923.hs

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 4492739b..819a4747 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -34,7 +34,7 @@ import qualified Data.Map as Map
 import           Data.Maybe
 import           Text.XHtml hiding     ( name, title, p, quote )
 
-import BasicTypes (PromotionFlag(..))
+import BasicTypes (PromotionFlag(..), isPromoted)
 import GHC hiding (LexicalFixity(..))
 import GHC.Exts
 import Name
@@ -1163,8 +1163,9 @@ ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
 
 ppr_mono_ty (HsBangTy _ b ty) u q _ =
   ppBang b +++ ppLParendType u q HideEmptyContexts ty
-ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ =
-  ppDocName q Prefix True name
+ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
+  | isPromoted prom = promoQuote (ppDocName q Prefix True name)
+  | otherwise = ppDocName q Prefix True name
 ppr_mono_ty (HsStarTy _ isUni) u _ _ =
   toHtml (if u || isUni then "★" else "*")
 ppr_mono_ty (HsFunTy _ ty1 ty2) u q e =
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 5ddc9eef..291af8de 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -500,9 +500,10 @@ synifyType _ (TyConApp tc tys)
                    tys_rest
       -- Most TyCons:
       | otherwise
-      = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc))
+      = mk_app_tys (HsTyVar noExt prom $ noLoc (getName tc))
                    vis_tys
       where
+        prom = if isPromotedDataCon tc then IsPromoted else NotPromoted
         mk_app_tys ty_app ty_args =
           foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2)
                 (noLoc ty_app)
diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html
index d7e120c9..1a906cc3 100644
--- a/html-test/ref/Bug548.html
+++ b/html-test/ref/Bug548.html
@@ -517,29 +517,29 @@
 			>Type</a
 			>) = <a href="#" title="GHC.Generics"
 			>D1</a
-			> (<a href="#" title="GHC.Generics"
+			> ('<a href="#" title="GHC.Generics"
 			>MetaData</a
-			> &quot;WrappedArrow&quot; &quot;Control.Applicative&quot; &quot;base&quot; <a href="#" title="Data.Bool"
+			> &quot;WrappedArrow&quot; &quot;Control.Applicative&quot; &quot;base&quot; '<a href="#" title="Data.Bool"
 			>True</a
 			>) (<a href="#" title="GHC.Generics"
 			>C1</a
-			> (<a href="#" title="GHC.Generics"
+			> ('<a href="#" title="GHC.Generics"
 			>MetaCons</a
-			> &quot;WrapArrow&quot; <a href="#" title="GHC.Generics"
+			> &quot;WrapArrow&quot; '<a href="#" title="GHC.Generics"
 			>PrefixI</a
-			> <a href="#" title="Data.Bool"
+			> '<a href="#" title="Data.Bool"
 			>True</a
 			>) (<a href="#" title="GHC.Generics"
 			>S1</a
-			> (<a href="#" title="GHC.Generics"
+			> ('<a href="#" title="GHC.Generics"
 			>MetaSel</a
-			> (<a href="#" title="GHC.Maybe"
+			> ('<a href="#" title="GHC.Maybe"
 			>Just</a
-			> &quot;unwrapArrow&quot;) <a href="#" title="GHC.Generics"
+			> &quot;unwrapArrow&quot;) '<a href="#" title="GHC.Generics"
 			>NoSourceUnpackedness</a
-			> <a href="#" title="GHC.Generics"
+			> '<a href="#" title="GHC.Generics"
 			>NoSourceStrictness</a
-			> <a href="#" title="GHC.Generics"
+			> '<a href="#" title="GHC.Generics"
 			>DecidedLazy</a
 			>) (<a href="#" title="GHC.Generics"
 			>Rec1</a
@@ -585,29 +585,29 @@
 			>WrappedArrow</a
 			> a b c) = <a href="#" title="GHC.Generics"
 			>D1</a
-			> (<a href="#" title="GHC.Generics"
+			> ('<a href="#" title="GHC.Generics"
 			>MetaData</a
-			> &quot;WrappedArrow&quot; &quot;Control.Applicative&quot; &quot;base&quot; <a href="#" title="Data.Bool"
+			> &quot;WrappedArrow&quot; &quot;Control.Applicative&quot; &quot;base&quot; '<a href="#" title="Data.Bool"
 			>True</a
 			>) (<a href="#" title="GHC.Generics"
 			>C1</a
-			> (<a href="#" title="GHC.Generics"
+			> ('<a href="#" title="GHC.Generics"
 			>MetaCons</a
-			> &quot;WrapArrow&quot; <a href="#" title="GHC.Generics"
+			> &quot;WrapArrow&quot; '<a href="#" title="GHC.Generics"
 			>PrefixI</a
-			> <a href="#" title="Data.Bool"
+			> '<a href="#" title="Data.Bool"
 			>True</a
 			>) (<a href="#" title="GHC.Generics"
 			>S1</a
-			> (<a href="#" title="GHC.Generics"
+			> ('<a href="#" title="GHC.Generics"
 			>MetaSel</a
-			> (<a href="#" title="GHC.Maybe"
+			> ('<a href="#" title="GHC.Maybe"
 			>Just</a
-			> &quot;unwrapArrow&quot;) <a href="#" title="GHC.Generics"
+			> &quot;unwrapArrow&quot;) '<a href="#" title="GHC.Generics"
 			>NoSourceUnpackedness</a
-			> <a href="#" title="GHC.Generics"
+			> '<a href="#" title="GHC.Generics"
 			>NoSourceStrictness</a
-			> <a href="#" title="GHC.Generics"
+			> '<a href="#" title="GHC.Generics"
 			>DecidedLazy</a
 			>) (<a href="#" title="GHC.Generics"
 			>Rec0</a
diff --git a/html-test/ref/Bug923.html b/html-test/ref/Bug923.html
new file mode 100644
index 00000000..1ad81835
--- /dev/null
+++ b/html-test/ref/Bug923.html
@@ -0,0 +1,200 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><meta name="viewport" content="width=device-width, initial-scale=1"
+     /><title
+    >Bug923</title
+    ><link href="#" rel="stylesheet" type="text/css" title="NewOcean"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+    ></script
+    ><script type="text/x-mathjax-config"
+    >MathJax.Hub.Config({ tex2jax: { processClass: &quot;mathjax&quot;, ignoreClass: &quot;.*&quot; } });</script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><span class="caption empty"
+      ></span
+      ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>Bug923</p
+	></div
+      ><div id="synopsis"
+      ><details id="syn"
+	><summary
+	  >Synopsis</summary
+	  ><ul class="details-toggle" data-details-id="syn"
+	  ><li class="src short"
+	    ><span class="keyword"
+	      >data</span
+	      > <a href="#"
+	      >T</a
+	      > :: (* -&gt; (*, *)) -&gt; * <span class="keyword"
+	      >where</span
+	      ><ul class="subs"
+	      ><li
+		><a href="#"
+		  >T</a
+		  > :: a -&gt; <a href="#" title="Bug923"
+		  >T</a
+		  > ('<a href="#" title="GHC.Tuple"
+		  >(,)</a
+		  > a)</li
+		></ul
+	      ></li
+	    ></ul
+	  ></details
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:T" class="def"
+	    >T</a
+	    > :: (* -&gt; (*, *)) -&gt; * <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >A promoted tuple type</p
+	    ></div
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a id="v:T" class="def"
+		  >T</a
+		  > :: a -&gt; <a href="#" title="Bug923"
+		  >T</a
+		  > ('<a href="#" title="GHC.Tuple"
+		  >(,)</a
+		  > a)</td
+		><td class="doc empty"
+		></td
+		></tr
+	      ></table
+	    ></div
+	  ><div class="subs instances"
+	  ><h4 class="instances details-toggle-control details-toggle" data-details-id="i:T"
+	    >Instances</h4
+	    ><details id="i:T" open="open"
+	    ><summary class="hide-when-js-enabled"
+	      >Instances details</summary
+	      ><table
+	      ><tr
+		><td class="src clearfix"
+		  ><span class="inst-left"
+		    ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Eq:1"
+		      ></span
+		      > <a href="#" title="Data.Eq"
+		      >Eq</a
+		      > a =&gt; <a href="#" title="Data.Eq"
+		      >Eq</a
+		      > (<a href="#" title="Bug923"
+		      >T</a
+		      > ('<a href="#" title="GHC.Tuple"
+		      >(,)</a
+		      > a :: <a href="#" title="Data.Kind"
+		      >Type</a
+		      > -&gt; (<a href="#" title="Data.Kind"
+		      >Type</a
+		      >, <a href="#" title="Data.Kind"
+		      >Type</a
+		      >)))</span
+		    > <a href="#" class="selflink"
+		    >#</a
+		    ></td
+		  ><td class="doc"
+		  ><p
+		    >A promoted tuple type in an instance</p
+		    ></td
+		  ></tr
+		><tr
+		><td colspan="2"
+		  ><details id="i:id:T:Eq:1"
+		    ><summary class="hide-when-js-enabled"
+		      >Instance details</summary
+		      ><p
+		      >Defined in <a href="#"
+			>Bug923</a
+			></p
+		      > <div class="subs methods"
+		      ><p class="caption"
+			>Methods</p
+			><p class="src"
+			><a href="#"
+			  >(==)</a
+			  > :: <a href="#" title="Bug923"
+			  >T</a
+			  > ('<a href="#" title="GHC.Tuple"
+			  >(,)</a
+			  > a) -&gt; <a href="#" title="Bug923"
+			  >T</a
+			  > ('<a href="#" title="GHC.Tuple"
+			  >(,)</a
+			  > a) -&gt; <a href="#" title="Data.Bool"
+			  >Bool</a
+			  > <a href="#" class="selflink"
+			  >#</a
+			  ></p
+			><p class="src"
+			><a href="#"
+			  >(/=)</a
+			  > :: <a href="#" title="Bug923"
+			  >T</a
+			  > ('<a href="#" title="GHC.Tuple"
+			  >(,)</a
+			  > a) -&gt; <a href="#" title="Bug923"
+			  >T</a
+			  > ('<a href="#" title="GHC.Tuple"
+			  >(,)</a
+			  > a) -&gt; <a href="#" title="Data.Bool"
+			  >Bool</a
+			  > <a href="#" class="selflink"
+			  >#</a
+			  ></p
+			></div
+		      ></details
+		    ></td
+		  ></tr
+		></table
+	      ></details
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html
index c9471477..59dfbb94 100644
--- a/html-test/ref/FunArgs.html
+++ b/html-test/ref/FunArgs.html
@@ -218,7 +218,7 @@
 	      ><td class="src"
 		>:: <span class="keyword"
 		  >forall</span
-		  > (b :: ()). d ~ <a href="#" title="GHC.Tuple"
+		  > (b :: ()). d ~ '<a href="#" title="GHC.Tuple"
 		  >()</a
 		  ></td
 		><td class="doc empty"
diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html
index b501a9a0..492b7ec1 100644
--- a/html-test/ref/TypeFamilies.html
+++ b/html-test/ref/TypeFamilies.html
@@ -224,11 +224,11 @@
 		  ><span class="inst-left"
 		    ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-62--60-:1"
 		      ></span
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XX</a
 		      > <a href="#" title="TypeFamilies"
 		      >&gt;&lt;</a
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XXX</a
 		      ></span
 		    > <a href="#" class="selflink"
@@ -386,11 +386,11 @@
 		      ></span
 		      > <span class="keyword"
 		      >type</span
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XXX</a
 		      > <a href="#" title="TypeFamilies"
 		      >&lt;&gt;</a
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XX</a
 		      ></span
 		    > <a href="#" class="selflink"
@@ -411,13 +411,13 @@
 		      > <div class="src"
 		      ><span class="keyword"
 			>type</span
-			> <a href="#" title="TypeFamilies"
+			> '<a href="#" title="TypeFamilies"
 			>XXX</a
 			> <a href="#" title="TypeFamilies"
 			>&lt;&gt;</a
-			> <a href="#" title="TypeFamilies"
+			> '<a href="#" title="TypeFamilies"
 			>XX</a
-			> = <a href="#" title="TypeFamilies"
+			> = '<a href="#" title="TypeFamilies"
 			>X</a
 			></div
 		      ></details
@@ -1115,7 +1115,7 @@
 			    >Z</a
 			    > -&gt; <a href="#" title="TypeFamilies"
 			    >Bat</a
-			    > <a href="#" title="TypeFamilies"
+			    > '<a href="#" title="TypeFamilies"
 			    >ZA</a
 			    ></li
 			  ><li class="inst"
@@ -1127,7 +1127,7 @@
 			    >Z</a
 			    >). {..} -&gt; <a href="#" title="TypeFamilies"
 			    >Bat</a
-			    > <a href="#" title="TypeFamilies"
+			    > '<a href="#" title="TypeFamilies"
 			    >ZB</a
 			    ></li
 			  ></ul
@@ -1401,7 +1401,7 @@
 			    >Z</a
 			    > -&gt; <a href="#" title="TypeFamilies"
 			    >Bat</a
-			    > <a href="#" title="TypeFamilies"
+			    > '<a href="#" title="TypeFamilies"
 			    >ZA</a
 			    ></li
 			  ><li class="inst"
@@ -1413,7 +1413,7 @@
 			    >Z</a
 			    >). {..} -&gt; <a href="#" title="TypeFamilies"
 			    >Bat</a
-			    > <a href="#" title="TypeFamilies"
+			    > '<a href="#" title="TypeFamilies"
 			    >ZB</a
 			    ></li
 			  ></ul
@@ -1770,11 +1770,11 @@
 		      ></span
 		      > <span class="keyword"
 		      >type</span
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XXX</a
 		      > <a href="#" title="TypeFamilies"
 		      >&lt;&gt;</a
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XX</a
 		      ></span
 		    > <a href="#" class="selflink"
@@ -1795,13 +1795,13 @@
 		      > <div class="src"
 		      ><span class="keyword"
 			>type</span
-			> <a href="#" title="TypeFamilies"
+			> '<a href="#" title="TypeFamilies"
 			>XXX</a
 			> <a href="#" title="TypeFamilies"
 			>&lt;&gt;</a
-			> <a href="#" title="TypeFamilies"
+			> '<a href="#" title="TypeFamilies"
 			>XX</a
-			> = <a href="#" title="TypeFamilies"
+			> = '<a href="#" title="TypeFamilies"
 			>X</a
 			></div
 		      ></details
@@ -1918,11 +1918,11 @@
 		  ><span class="inst-left"
 		    ><span class="instance details-toggle-control details-toggle" data-details-id="i:ic:-62--60-:-62--60-:1"
 		      ></span
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XX</a
 		      > <a href="#" title="TypeFamilies"
 		      >&gt;&lt;</a
-		      > <a href="#" title="TypeFamilies"
+		      > '<a href="#" title="TypeFamilies"
 		      >XXX</a
 		      ></span
 		    > <a href="#" class="selflink"
diff --git a/html-test/src/Bug923.hs b/html-test/src/Bug923.hs
new file mode 100644
index 00000000..bb5bca0a
--- /dev/null
+++ b/html-test/src/Bug923.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE KindSignatures, FlexibleInstances, GADTs, DataKinds #-}
+module Bug923 where
+
+-- | A promoted tuple type
+data T :: (* -> (*,*)) -> * where
+  T :: a -> T ('(,) a)
+
+-- | A promoted tuple type in an instance
+instance Eq a => Eq (T ('(,) a)) where
+  T x == T y = x == y
+
-- 
cgit v1.2.3