From 00571a39acaa5aaa292b5a4bd5c17f122951f7ae Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 18:21:04 +0200
Subject: Apply type specializer to associated type family declarations.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs       |  7 ++++---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 14 +++++++++++++-
 2 files changed, 17 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e6869916..294af864 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -567,7 +567,7 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
             sigs = ppInstanceSigs links splice unicode qual
                 clsiTyVars ihdTypes clsiSigs
             ats = ppInstanceAssocTys links splice unicode qual
-                clsiAssocTys
+                clsiTyVars ihdTypes clsiAssocTys
         TypeInst rhs ->
             (ptype, mdoc, [])
           where
@@ -588,10 +588,11 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
 
 
 ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
+                   -> LHsTyVarBndrs DocName -> [HsType DocName]
                    -> [PseudoFamilyDecl DocName]
                    -> [Html]
-ppInstanceAssocTys links splice unicode qual =
-    map ppFamilyDecl'
+ppInstanceAssocTys links splice unicode qual bndrs tys =
+    map ppFamilyDecl' . map (specializePseudoFamilyDecl bndrs tys)
   where
     ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index a8a4e8ec..109788fd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -7,6 +7,7 @@
 module Haddock.Backends.Xhtml.Specialize
     ( specialize, specialize'
     , specializeTyVarBndrs
+    , specializePseudoFamilyDecl
     , sugar, rename
     , freeVariables
     ) where
@@ -58,8 +59,9 @@ specialize' = flip $ foldr (uncurry specialize)
 -- Again, it is just a convenience function around 'specialize'. Note that
 -- length of type list should be the same as the number of binders.
 specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
+                     => Data a
                      => LHsTyVarBndrs name -> [HsType name]
-                     -> HsType name -> HsType name
+                     -> a -> a
 specializeTyVarBndrs bndrs typs =
     specialize' $ zip bndrs' typs
   where
@@ -68,6 +70,16 @@ specializeTyVarBndrs bndrs typs =
     bname (KindedTyVar (L _ name) _) = name
 
 
+specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
+                           => LHsTyVarBndrs name -> [HsType name]
+                           -> PseudoFamilyDecl name
+                           -> PseudoFamilyDecl name
+specializePseudoFamilyDecl bndrs typs decl =
+    decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }
+  where
+    specializeTyVars = specializeTyVarBndrs bndrs typs
+
+
 -- | Make given type use tuple and list literals where appropriate.
 --
 -- After applying 'specialize' function some terms may not use idiomatic list
-- 
cgit v1.2.3