Refactor specializer module to be independent from XHTML backend.

3 files changed, 27 insertions, 15 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 7255bf42..7da1f08e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -22,7 +22,6 @@ module Haddock.Backends.Xhtml.Decl (
 import Haddock.Backends.Xhtml.DocMarkup
 import Haddock.Backends.Xhtml.Layout
 import Haddock.Backends.Xhtml.Names
-import Haddock.Backends.Xhtml.Specialize
 import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
@@ -563,10 +562,8 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
             )
           where
             iid = instanceId origin no ihdClsName
-            sigs = ppInstanceSigs links splice unicode qual
-                clsiTyVars ihdTypes clsiSigs
-            ats = ppInstanceAssocTys links splice unicode qual
-                clsiTyVars ihdTypes clsiAssocTys
+            sigs = ppInstanceSigs links splice unicode qual clsiSigs
+            ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
         TypeInst rhs ->
             (ptype, mdoc, [])
           where
@@ -587,20 +584,19 @@ 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 bndrs tys =
-    map ppFamilyDecl' . map (specializePseudoFamilyDecl bndrs tys)
+ppInstanceAssocTys links splice unicode qual =
+    map ppFamilyDecl'
   where
     ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
 
 
 ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-              -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName]
+              -> [Sig DocName]
               -> [Html]
-ppInstanceSigs links splice unicode qual bndrs tys sigs = do
-    TypeSig lnames (L loc typ) _ <- map (specializeSig bndrs tys) sigs
+ppInstanceSigs links splice unicode qual sigs = do
+    TypeSig lnames (L loc typ) _ <- sigs
     let names = map unLoc lnames
     return $ ppSimpleSig links splice unicode qual loc names typ
 
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 095bd9e0..c9664652 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -25,7 +25,6 @@ import Data.Either (lefts, rights)
 import Data.List( partition )
 import DataCon
 import FamInstEnv
-import Haddock.Types
 import HsSyn
 import Kind ( splitKindFunTys, synTyConResKind, isKind )
 import Name
@@ -41,6 +40,9 @@ import TysWiredIn ( listTyConName, eqTyCon )
 import Unique ( getUnique )
 import Var
 
+import Haddock.Types
+import Haddock.Interface.Specialize
+
 
 
 -- the main function here! yay!
@@ -390,7 +392,7 @@ synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) = InstHead
+synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
     { ihdClsName = getName cls
     , ihdKinds = map (unLoc . synifyType WithinType) ks
     , ihdTypes = map (unLoc . synifyType WithinType) ts
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 2295605b..df7f63bc 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -4,8 +4,8 @@
 {-# LANGUAGE RecordWildCards #-}
 
 
-module Haddock.Backends.Xhtml.Specialize
-    ( specializePseudoFamilyDecl, specializeSig
+module Haddock.Interface.Specialize
+    ( specializeInstHead
     ) where
 
 
@@ -88,6 +88,20 @@ specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
 specializeSig _ _ sig = sig
 
 
+specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name)
+                   => InstHead name -> InstHead name
+specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
+    ihd { ihdInstType = instType' }
+  where
+    instType' = clsi
+        { clsiSigs = map specializeSig' clsiSigs
+        , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys
+        }
+    specializeSig' = specializeSig clsiTyVars ihdTypes
+    specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes
+specializeInstHead ihd = ihd
+
+
 -- | Make given type use tuple and list literals where appropriate.
 --
 -- After applying 'specialize' function some terms may not use idiomatic list