Overhaul Haddock's rendering of kind signatures (#681)

* Overhaul Haddock's rendering of kind signatures

* Strip off kind signatures when specializing

As an added bonus, this lets us remove an ugly hack specifically for `(->)`.
Yay!

* Update due to 0390e4a0f61e37bd1dcc24a36d499e92f2561b67

* @alexbiehl's suggestions

* Import injectiveVarsOfBinder from GHC

6 files changed, 148 insertions, 75 deletions

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 1cc23e6e..d79e0e6c 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -553,7 +553,7 @@ ppInstHead unicode (InstHead {..}) = case ihdInstType of
     TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
     DataInst _ -> error "data instances not supported by --latex yet"
   where
-    typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode
+    typ = ppAppNameTypes ihdClsName ihdTypes unicode
     tibody = maybe empty (\t -> equals <+> ppType unicode t)
 
 lookupAnySubdoc :: (Eq name1) =>
@@ -831,27 +831,27 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
 --------------------------------------------------------------------------------
 
 
--- | Print an application of a DocName and two lists of HsTypes (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI] -> Bool -> LaTeX
-ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)
+-- | Print an application of a DocName to its list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
 
 
 -- | Print an application of a DocName and a list of Names
 ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
 ppAppDocNameNames _summ n ns =
-  ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName
+  ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName
 
 
 -- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
+ppTypeApp n (t1:t2:rest) ppDN ppT
   | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
   | operator                    = opApp
   where
     operator = isNameSym . getName $ n
     opApp = ppT t1 <+> ppDN n <+> ppT t2
 
-ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
+ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
 
 
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3b53b1eb..3b85f96c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -286,7 +286,7 @@ ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
                      -> Html
 ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
     ppFamilyInfo True pfdInfo <+>
-    ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
+    ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+>
     ppResultSig (unLoc pfdKindSig) unicode qual
 
 ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html
@@ -321,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
     ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
     ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs
                                           , feqn_pats = ts } })
-      = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
+      = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
           <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
         , Nothing, [] )
 
@@ -368,29 +368,28 @@ ppDataBinderWithVars summ unicode qual decl =
 
 ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
 ppAppDocNameTyVarBndrs summ unicode qual n vs =
-    ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
+    ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
   where
     ppDN notation = ppBinderFixity notation summ . nameOccName . getName
     ppBinderFixity Infix = ppBinderInfix
     ppBinderFixity _ = ppBinder
 
--- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI]
-               -> Unicode -> Qualification -> Html
-ppAppNameTypes n ks ts unicode qual =
-    ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
+-- | Print an application of a 'DocName' to its list of 'HsType's
+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html
+ppAppNameTypes n ts unicode qual =
+    ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
 
 
 -- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n (t1:t2:rest) ppDN ppT
   | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
   | operator                    = opApp
   where
     operator = isNameSym . getName $ n
     opApp = ppT t1 <+> ppDN Infix n <+> ppT t2
 
-ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
+ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
 
 
 -------------------------------------------------------------------------------
@@ -621,7 +620,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
             pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
   where
     iid = instanceId origin no orphan ihd
-    typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
+    typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
 
 
 ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 67aa88e1..325d9cf6 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -25,6 +25,7 @@ import ConLike
 import Data.Either (lefts, rights)
 import DataCon
 import FamInstEnv
+import FV
 import HsSyn
 import Name
 import NameSet ( emptyNameSet )
@@ -37,11 +38,12 @@ import Type
 import TyCoRep
 import TysPrim ( alphaTyVars )
 import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
-import PrelNames ( hasKey, eqTyConKey, ipClassKey
+import PrelNames ( hasKey, eqTyConKey, funTyConKey, ipClassKey
                  , tYPETyConKey, liftedRepDataConKey )
 import Unique ( getUnique )
-import Util ( filterByList, filterOut )
+import Util ( compareLength, filterByList, filterOut, splitAtList )
 import Var
+import VarSet
 
 import Haddock.Types
 import Haddock.Interface.Specialize
@@ -77,7 +79,7 @@ tyThingToLHsDecl t = case t of
        in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl
          { tcdCtxt = synifyCtx (classSCTheta cl)
          , tcdLName = synifyName cl
-         , tcdTyVars = synifyTyVars (classTyVars cl)
+         , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))
          , tcdFixity = Prefix
          , tcdFDs = map (\ (l,r) -> noLoc
                         (map (noLoc . getName) l, map (noLoc . getName) r) ) $
@@ -110,15 +112,20 @@ tyThingToLHsDecl t = case t of
 
 synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
 synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
-  = let name       = synifyName tc
-        typats     = map (synifyType WithinType) args
-        hs_rhs     = synifyType WithinType rhs
+  = let name            = synifyName tc
+        args_types_only = filterOutInvisibleTypes tc args
+        typats          = map (synifyType WithinType) args_types_only
+        annot_typats    = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
+                                   args_types_only typats
+        hs_rhs          = synifyType WithinType rhs
     in HsIB { hsib_vars   = map tyVarName tkvs
             , hsib_closed = True
             , hsib_body   = FamEqn { feqn_tycon  = name
-                                   , feqn_pats   = typats
+                                   , feqn_pats   = annot_typats
                                    , feqn_fixity = Prefix
                                    , feqn_rhs    = hs_rhs } }
+  where
+    fam_tvs = tyConVisibleTyVars tc
 
 synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
 synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
@@ -185,7 +192,7 @@ synifyTyCon _coax tc
     mkFamDecl i = return $ FamDecl $
       FamilyDecl { fdInfo = i
                  , fdLName = synifyName tc
-                 , fdTyVars = synifyTyVars (tyConTyVars tc)
+                 , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
                  , fdFixity = Prefix
                  , fdResultSig =
                        synifyFamilyResultSig resultVar (tyConResKind tc)
@@ -197,7 +204,7 @@ synifyTyCon _coax tc
 synifyTyCon coax tc
   | Just ty <- synTyConRhs_maybe tc
   = return $ SynDecl { tcdLName = synifyName tc
-                     , tcdTyVars = synifyTyVars (tyConTyVars tc)
+                     , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
                      , tcdFixity = Prefix
                      , tcdRhs = synifyType WithinType ty
                      , tcdFVs = placeHolderNamesTc }
@@ -210,7 +217,7 @@ synifyTyCon coax tc
     Just a -> synifyName a -- Data families are named according to their
                            -- CoAxioms, not their TyCons
     _ -> synifyName tc
-  tyvars = synifyTyVars (tyConTyVars tc)
+  tyvars = synifyTyVars (tyConVisibleTyVars tc)
   kindSig = Just (tyConKind tc)
   -- The data constructors.
   --
@@ -345,6 +352,33 @@ synifyTyVar tv
     kind = tyVarKind tv
     name = getName tv
 
+-- | Annotate (with HsKingSig) a type if the first parameter is True
+-- and if the type contains a free variable.
+-- This is used to synify type patterns for poly-kinded tyvars in
+-- synifying class and type instances.
+annotHsType :: Bool   -- True <=> annotate
+            -> Type -> LHsType GhcRn -> LHsType GhcRn
+  -- tiny optimization: if the type is annotated, don't annotate again.
+annotHsType _    _  hs_ty@(L _ (HsKindSig {})) = hs_ty
+annotHsType True ty hs_ty
+  | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
+  = let ki    = typeKind ty
+        hs_ki = synifyType WithinType ki
+    in noLoc (HsKindSig hs_ty hs_ki)
+annotHsType _    _ hs_ty = hs_ty
+
+-- | For every type variable in the input,
+-- report whether or not the tv is poly-kinded. This is used to eventually
+-- feed into 'annotHsType'.
+mkIsPolyTvs :: [TyVar] -> [Bool]
+mkIsPolyTvs = map is_poly_tv
+  where
+    is_poly_tv tv = not $
+                    isEmptyVarSet $
+                    filterVarSet isTyVar $
+                    tyCoVarsOfType $
+                    tyVarKind tv
+
 --states of what to do with foralls:
 data SynifyTypeState
   = WithinType
@@ -377,37 +411,68 @@ synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
 synifyType :: SynifyTypeState -> Type -> LHsType GhcRn
 synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)
 synifyType _ (TyConApp tc tys)
-  -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
-  | tc `hasKey` tYPETyConKey
-  , [TyConApp lev []] <- tys
-  , lev `hasKey` liftedRepDataConKey
-  = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
-  -- Use non-prefix tuple syntax where possible, because it looks nicer.
-  | Just sort <- tyConTuple_maybe tc
-  , tyConArity tc == length tys
-  = noLoc $ HsTupleTy (case sort of
-                          BoxedTuple      -> HsBoxedTuple
-                          ConstraintTuple -> HsConstraintTuple
-                          UnboxedTuple    -> HsUnboxedTuple)
-                       (map (synifyType WithinType) tys)
-  -- ditto for lists
-  | getName tc == listTyConName, [ty] <- tys =
-     noLoc $ HsListTy (synifyType WithinType ty)
-  -- ditto for implicit parameter tycons
-  | tc `hasKey` ipClassKey
-  , [name, ty] <- tys
-  , Just x <- isStrLitTy name
-  = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
-  -- and equalities
-  | tc `hasKey` eqTyConKey
-  , [ty1, ty2] <- tys
-  = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
-  -- Most TyCons:
-  | otherwise =
-    foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
-      (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc))
-      (map (synifyType WithinType) $
-       filterOut isCoercionTy tys)
+  = maybe_sig res_ty
+  where
+    res_ty :: LHsType GhcRn
+    res_ty
+      -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
+      | tc `hasKey` tYPETyConKey
+      , [TyConApp lev []] <- tys
+      , lev `hasKey` liftedRepDataConKey
+      = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
+      -- Use non-prefix tuple syntax where possible, because it looks nicer.
+      | Just sort <- tyConTuple_maybe tc
+      , tyConArity tc == length tys
+      = noLoc $ HsTupleTy (case sort of
+                              BoxedTuple      -> HsBoxedTuple
+                              ConstraintTuple -> HsConstraintTuple
+                              UnboxedTuple    -> HsUnboxedTuple)
+                           (map (synifyType WithinType) vis_tys)
+      -- ditto for lists
+      | getName tc == listTyConName, [ty] <- tys =
+         noLoc $ HsListTy (synifyType WithinType ty)
+      -- ditto for implicit parameter tycons
+      | tc `hasKey` ipClassKey
+      , [name, ty] <- tys
+      , Just x <- isStrLitTy name
+      = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
+      -- and equalities
+      | tc `hasKey` eqTyConKey
+      , [ty1, ty2] <- tys
+      = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
+      -- Most TyCons:
+      | otherwise =
+        foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
+          (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc))
+          (map (synifyType WithinType) $
+           filterOut isCoercionTy vis_tys)
+
+    vis_tys  = filterOutInvisibleTypes tc tys
+    binders  = tyConBinders tc
+    res_kind = tyConResKind tc
+
+    maybe_sig :: LHsType GhcRn -> LHsType GhcRn
+    maybe_sig ty'
+      | needs_kind_sig
+      = let full_kind  = typeKind (mkTyConApp tc tys)
+            full_kind' = synifyType WithinType full_kind
+        in noLoc $ HsKindSig ty' full_kind'
+      | otherwise = ty'
+
+    needs_kind_sig :: Bool
+    needs_kind_sig
+      | GT <- compareLength tys binders
+      = False
+      | otherwise
+      = let (dropped_binders, remaining_binders)
+                  = splitAtList  tys binders
+            result_kind  = mkTyConKind remaining_binders res_kind
+            result_vars  = tyCoVarsOfType result_kind
+            dropped_vars = fvVarSet $
+                           mapUnionFV injectiveVarsOfBinder dropped_binders
+
+        in not (subVarSet result_vars dropped_vars)
+
 synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
 synifyType _ (AppTy t1 t2) = let
   s1 = synifyType WithinType t1
@@ -457,11 +522,10 @@ synifyKindSig k = synifyType WithinType k
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
 synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
     { ihdClsName = getName cls
-    , ihdKinds = map (unLoc . synifyType WithinType) ks
-    , ihdTypes = map (unLoc . synifyType WithinType) ts
+    , ihdTypes = map unLoc annot_ts
     , ihdInstType = ClassInst
         { clsiCtx = map (unLoc . synifyType WithinType) preds
-        , clsiTyVars = synifyTyVars $ classTyVars cls
+        , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
         , clsiSigs = map synifyClsIdSig $ classMethods cls
         , clsiAssocTys = do
             (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
@@ -469,7 +533,11 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
         }
     }
   where
-    (ks,ts) = partitionInvisibles (classTyCon cls) id types
+    cls_tycon = classTyCon cls
+    ts  = filterOutInvisibleTypes cls_tycon types
+    ts' = map (synifyType WithinType) ts
+    annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
+    is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)
     synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification
 
 -- Convert a family instance, this could be a type family or data family
@@ -478,8 +546,7 @@ synifyFamInst fi opaque = do
     ityp' <- ityp $ fi_flavor fi
     return InstHead
         { ihdClsName = fi_fam fi
-        , ihdKinds = synifyTypes ks
-        , ihdTypes = synifyTypes ts
+        , ihdTypes = map unLoc annot_ts
         , ihdInstType = ityp'
         }
   where
@@ -488,5 +555,9 @@ synifyFamInst fi opaque = do
         return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
     ityp (DataFamilyInst c) =
         DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
-    (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
-    synifyTypes = map (unLoc. synifyType WithinType)
+    fam_tc = famInstTyCon fi
+    ts = filterOutInvisibleTypes fam_tc $ fi_tys fi
+    synifyTypes = map (synifyType WithinType)
+    ts' = synifyTypes ts
+    annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
+    is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 70962d9c..7023a908 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -294,7 +294,6 @@ renameWildCardInfo (AnonWildCard  (L l name)) = AnonWildCard . L l <$> rename na
 renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
 renameInstHead InstHead {..} = do
   cname <- rename ihdClsName
-  kinds <- mapM renameType ihdKinds
   types <- mapM renameType ihdTypes
   itype <- case ihdInstType of
     ClassInst { .. } -> ClassInst
@@ -306,7 +305,6 @@ renameInstHead InstHead {..} = do
     DataInst  dd -> DataInst  <$> renameTyClD dd
   return InstHead
     { ihdClsName = cname
-    , ihdKinds = kinds
     , ihdTypes = types
     , ihdInstType = itype
     }
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 0c8e89c2..6d2888d3 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -34,7 +34,13 @@ specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)
 specialize specs = go
   where
     go :: forall x. Data x => x -> x
-    go = everywhereButType @name $ mkT $ sugar . specialize_ty_var
+    go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+
+    strip_kind_sig :: HsType name -> HsType name
+    strip_kind_sig (HsKindSig (L _ t) _) = t
+    strip_kind_sig typ = typ
+
+    specialize_ty_var :: HsType name -> HsType name
     specialize_ty_var (HsTyVar _ (L _ name'))
       | Just t <- Map.lookup name' spec_map = t
     specialize_ty_var typ = typ
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 188611a0..b4cdc343 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -390,11 +390,10 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
 -- | An instance head that may have documentation and a source location.
 type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name))
 
--- | The head of an instance. Consists of a class name, a list of kind
--- parameters, a list of type parameters and an instance type
+-- | The head of an instance. Consists of a class name, a list of type
+-- parameters (which may be annotated with kinds), and an instance type
 data InstHead name = InstHead
     { ihdClsName :: IdP name
-    , ihdKinds :: [HsType name]
     , ihdTypes :: [HsType name]
     , ihdInstType :: InstType name
     }