Explicit Specificity Support for Haddock

9 files changed, 124 insertions, 69 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 5d658a7e..e03611b2 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -252,8 +252,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
         -- docs for con_names on why it is a list to begin with.
         name = commaSeparate dflags . map unL $ getConNames con
 
-        tyVarArg (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
-        tyVarArg (KindedTyVar _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
+        tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
+        tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
         tyVarArg _ = panic "ppCtor"
 
         resType = apps $ map reL $
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index c54cc459..13f22db7 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -29,6 +29,7 @@ import GHC
 import GHC.Types.Name.Occurrence
 import GHC.Types.Name        ( nameOccName )
 import GHC.Types.Name.Reader ( rdrNameOcc )
+import GHC.Core.Type         ( Specificity(..) )
 import GHC.Data.FastString   ( unpackFS )
 import GHC.Utils.Outputable  ( panic)
 
@@ -518,7 +519,7 @@ ppTypeSig nms ty unicode =
     <+> ppType unicode ty
 
 
-ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX]
+ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX]
 ppTyVars = map (ppSymName . getName . hsLTyVarNameI)
 
 
@@ -897,7 +898,8 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
 -- * Type applications
 --------------------------------------------------------------------------------
 
-ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX
+ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>
+  Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX
 ppAppDocNameTyVarBndrs unicode n vs =
     ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)
   where
@@ -1007,10 +1009,21 @@ ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>
                                        ppLParendType unicode ki
 ppLHsTypeArg _ (HsArgPar _) = text ""
 
-ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
-ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
-ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =
-  parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
+class RenderableBndrFlag flag where
+  ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX
+
+instance RenderableBndrFlag () where
+  ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name
+  ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) =
+    parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
+
+instance RenderableBndrFlag Specificity where
+  ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name
+  ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name
+  ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) =
+    parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
+  ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) =
+    braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
 
 ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
 ppLKind unicode y = ppKind unicode (unLoc y)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a8ff584d..76b5fae8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -34,6 +34,7 @@ import qualified Data.Map as Map
 import           Data.Maybe
 import           Text.XHtml hiding     ( name, title, p, quote )
 
+import GHC.Core.Type ( Specificity(..) )
 import GHC.Types.Basic (PromotionFlag(..), isPromoted)
 import GHC hiding (LexicalFixity(..))
 import GHC.Exts
@@ -188,10 +189,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
 
 
 
-ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> ForallVisFlag
+ppForAll :: [LHsTyVarBndr flag DocNameI] -> Unicode -> Qualification -> ForallVisFlag
          -> Html
 ppForAll tvs unicode qual fvf =
-  case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
+  case [ppKTv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of
     [] -> noHtml
     ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf
   where ppKTv n k = parens $
@@ -226,7 +227,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
 
 
 -- | Pretty-print type variables.
-ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]
+ppTyVars :: RenderableBndrFlag flag =>
+  Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html]
 ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs
 
 
@@ -407,7 +409,8 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
 -- * Type applications
 --------------------------------------------------------------------------------
 
-ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
+ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>
+  Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html
 ppAppDocNameTyVarBndrs summ unicode qual n vs =
     ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
   where
@@ -1107,12 +1110,28 @@ ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual
 ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>
                                                        ppLParendType unicode qual emptyCtxts ki
 ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""
-ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
-ppHsTyVarBndr _       qual (UserTyVar _ (L _ name)) =
-    ppDocName qual Raw False name
-ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
-    parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
-            ppLKind unicode qual kind)
+
+class RenderableBndrFlag flag where
+  ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html
+
+instance RenderableBndrFlag () where
+  ppHsTyVarBndr _       qual (UserTyVar _ _ (L _ name)) =
+      ppDocName qual Raw False name
+  ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) =
+      parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+              ppLKind unicode qual kind)
+
+instance RenderableBndrFlag Specificity where
+  ppHsTyVarBndr _       qual (UserTyVar _ SpecifiedSpec (L _ name)) =
+      ppDocName qual Raw False name
+  ppHsTyVarBndr _       qual (UserTyVar _ InferredSpec (L _ name)) =
+      braces $ ppDocName qual Raw False name
+  ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =
+      parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+              ppLKind unicode qual kind)
+  ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =
+      braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+              ppLKind unicode qual kind)
 
 ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
 ppLKind unicode qual y = ppKind unicode qual (unLoc y)
@@ -1146,7 +1165,8 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
 ppPatSigType unicode qual typ =
   let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
 
-ppForAllPart :: Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr DocNameI] -> Html
+ppForAllPart :: RenderableBndrFlag flag =>
+  Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr flag DocNameI] -> Html
 ppForAllPart unicode qual fvf tvs =
   hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++
   ppForAllSeparator unicode fvf
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 6a9598ed..0020fc4c 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -47,6 +47,7 @@ import GHC.Types.Unique ( getUnique )
 import GHC.Utils.Misc ( chkAppend,dropList, filterByList, filterOut )
 import GHC.Types.Var
 import GHC.Types.Var.Set
+import GHC.Types.SrcLoc
 
 import Haddock.Types
 import Haddock.Interface.Specialize
@@ -85,6 +86,15 @@ tyThingToLHsDecl prr t = case t of
            extractFamilyDecl _           =
              Left "tyThingToLHsDecl: impossible associated tycon"
 
+           cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
+           cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField
+              (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind
+           cvt (XTyVarBndr nec) = noExtCon nec
+
+           -- | Convert a LHsTyVarBndr to an equivalent LHsType.
+           hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)
+           hsLTyVarBndrToType = mapLoc cvt
+
            extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
            extractFamDefDecl fd rhs =
              TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)
@@ -210,8 +220,8 @@ synifyTyCon prr _coax tc
   where
     -- tyConTyVars doesn't work on fun/prim, but we can make them up:
     mk_hs_tv realKind fakeTyVar
-      | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField (noLoc (getName fakeTyVar))
-      | otherwise = noLoc $ KindedTyVar noExtField (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
+      | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar))
+      | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
 
     conKind = defaultType prr (tyConKind tc)
     tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind
@@ -335,7 +345,7 @@ synifyFamilyResultSig  Nothing    kind
    | isLiftedTypeKind kind = noLoc $ NoSig noExtField
    | otherwise = noLoc $ KindSig  noExtField (synifyKindSig kind)
 synifyFamilyResultSig (Just name) kind =
-   noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField (noLoc name) (synifyKindSig kind))
+   noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))
 
 -- User beware: it is your responsibility to pass True (use_gadt_syntax)
 -- for any constructor that would be misrepresented by omitting its
@@ -352,7 +362,7 @@ synifyDataCon use_gadt_syntax dc =
   name = synifyName dc
   -- con_qvars means a different thing depending on gadt-syntax
   (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
-  user_tvs = dataConUserTyVars dc -- Used for GADT data constructors
+  user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors
 
   -- skip any EqTheta, use 'orig'inal syntax
   ctx | null theta = Nothing
@@ -382,10 +392,10 @@ synifyDataCon use_gadt_syntax dc =
       \hat ->
         if use_gadt_syntax
            then return $ noLoc $
-              ConDeclGADT { con_g_ext  = noExtField
+              ConDeclGADT { con_g_ext  = []
                           , con_names  = [name]
-                          , con_forall = noLoc $ not $ null user_tvs
-                          , con_qvars  = synifyTyVars user_tvs
+                          , con_forall = noLoc $ not $ null user_tvbndrs
+                          , con_qvars  = map synifyInvisTyVar user_tvbndrs
                           , con_mb_cxt = ctx
                           , con_args   = hat
                           , con_res_ty = synifyType WithinType [] res_ty
@@ -394,7 +404,7 @@ synifyDataCon use_gadt_syntax dc =
               ConDeclH98 { con_ext    = noExtField
                          , con_name   = name
                          , con_forall = noLoc False
-                         , con_ex_tvs = map synifyTyVar ex_tvs
+                         , con_ex_tvs = map (synifyInvisTyVar . (mkTyCoVarBinder InferredSpec)) ex_tvs
                          , con_mb_cxt = ctx
                          , con_args   = hat
                          , con_doc    = Nothing }
@@ -439,20 +449,27 @@ synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
 synifyTyVars ktvs = HsQTvs { hsq_ext = []
                            , hsq_explicit = map synifyTyVar ktvs }
 
-synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
+synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn
 synifyTyVar = synifyTyVar' emptyVarSet
 
+synifyInvisTyVar :: InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
+synifyInvisTyVar = synifyInvisTyVar' emptyVarSet
+
 -- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind
 -- signatures (even if they don't have the lifted type kind).
-synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn
+synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr () GhcRn
 synifyTyVar' no_kinds tv
   | isLiftedTypeKind kind || tv `elemVarSet` no_kinds
-  = noLoc (UserTyVar noExtField (noLoc name))
-  | otherwise = noLoc (KindedTyVar noExtField (noLoc name) (synifyKindSig kind))
+  = noLoc (UserTyVar noExtField () (noLoc name))
+  | otherwise = noLoc (KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))
   where
     kind = tyVarKind tv
     name = getName tv
 
+synifyInvisTyVar' :: VarSet -> InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
+synifyInvisTyVar' no_kinds (Bndr tv spec) = case (synifyTyVar' no_kinds tv) of
+  L l (UserTyVar   ne _ n)   -> L l (UserTyVar   ne spec n)
+  L l (KindedTyVar ne _ n k) -> L l (KindedTyVar ne spec n k)
 
 -- | Annotate (with HsKingSig) a type if the first parameter is True
 -- and if the type contains a free variable.
@@ -631,6 +648,7 @@ synifyForAllType
   -> LHsType GhcRn
 synifyForAllType s argf vs ty =
   let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty
+      inv_tvs = map to_invis_bndr tvs
       sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
                       , hst_xqual = noExtField
                       , hst_body = synifyType WithinType (tvs' ++ vs) tau }
@@ -640,7 +658,7 @@ synifyForAllType s argf vs ty =
                        , hst_xforall = noExtField
                        , hst_body  = noLoc sPhi }
 
-      sTvs = map synifyTyVar tvs
+      sTvs = map synifyInvisTyVar inv_tvs
 
       -- Figure out what the type variable order would be inferred in the
       -- absence of an explicit forall
@@ -654,8 +672,12 @@ synifyForAllType s argf vs ty =
       | not (null tvs) -> noLoc sTy
       | otherwise -> noLoc sPhi
 
-    ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
+    ImplicitizeForAll -> implicitForAll [] vs inv_tvs ctx (synifyType WithinType) tau
 
+  where
+    to_invis_bndr :: TyVarBinder -> InvisTVBinder
+    to_invis_bndr (Bndr tv Required)         = Bndr tv SpecifiedSpec
+    to_invis_bndr (Bndr tv (Invisible spec)) = Bndr tv spec
 
 -- | Put a forall in if there are any type variables which require
 -- explicit kind annotations or if the inferred type variable order
@@ -663,14 +685,14 @@ synifyForAllType s argf vs ty =
 implicitForAll
   :: [TyCon]          -- ^ type constructors that determine their args kinds
   -> [TyVar]          -- ^ free variables in the type to convert
-  -> [TyVar]          -- ^ type variable binders in the forall
+  -> [InvisTVBinder]  -- ^ type variable binders in the forall
   -> ThetaType        -- ^ constraints right after the forall
   -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type
   -> Type             -- ^ inner type
   -> LHsType GhcRn
 implicitForAll tycons vs tvs ctx synInner tau
   | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy
-  | tvs' /= tvs                        = noLoc sTy
+  | tvs' /= (binderVars tvs)           = noLoc sTy
   | otherwise                          = noLoc sPhi
   where
   sRho = synInner (tvs' ++ vs) tau
@@ -685,7 +707,7 @@ implicitForAll tycons vs tvs ctx synInner tau
                    , hst_body = noLoc sPhi }
 
   no_kinds_needed = noKindTyVars tycons tau
-  sTvs = map (synifyTyVar' no_kinds_needed) tvs
+  sTvs = map (synifyInvisTyVar' no_kinds_needed) tvs
 
   -- Figure out what the type variable order would be inferred in the
   -- absence of an explicit forall
@@ -729,7 +751,7 @@ noKindTyVars _ _ = emptyVarSet
 
 synifyPatSynType :: PatSyn -> LHsType GhcRn
 synifyPatSynType ps =
-  let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
+  let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
       ts = maybeToList (tyConAppTyCon_maybe res_ty)
 
       -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
@@ -831,18 +853,18 @@ invariant didn't hold.
 -- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms.
 --
 -- See Note [Invariant: Never expand type synonyms]
-tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], ThetaType, Type)
+tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], ThetaType, Type)
 tcSplitSigmaTySameVisPreserveSynonyms argf ty =
     case tcSplitForAllTysSameVisPreserveSynonyms argf ty of
       (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of
         (theta, tau) -> (tvs, theta, tau)
 
 -- | See Note [Invariant: Never expand type synonyms]
-tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type)
+tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], Type)
 tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty []
   where
-    split _       (ForAllTy (Bndr tv argf) ty') tvs
-      | argf `sameVis` supplied_argf                = split ty' ty' (tv:tvs)
+    split _       (ForAllTy tvbndr@(Bndr _ argf) ty') tvs
+      | argf `sameVis` supplied_argf                = split ty' ty' (tvbndr:tvs)
     split orig_ty _                             tvs = (reverse tvs, orig_ty)
 
 -- | See Note [Invariant: Never expand type synonyms]
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index b60b13a4..dbe9ec3c 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -161,11 +161,11 @@ nubByName f ns = go emptyNameSet ns
 -- These functions are duplicated from the GHC API, as they must be
 -- instantiated at DocNameI instead of (GhcPass _).
 
-hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName
-hsTyVarNameI (UserTyVar _ (L _ n))     = n
-hsTyVarNameI (KindedTyVar _ (L _ n) _) = n
+hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName
+hsTyVarNameI (UserTyVar _ _ (L _ n))     = n
+hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n
 
-hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName
+hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName
 hsLTyVarNameI = hsTyVarNameI . unLoc
 
 getConNamesI :: ConDecl DocNameI -> [Located DocName]
@@ -189,7 +189,7 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
                             , con_res_ty = res_ty })
  | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
                                   , hst_xforall = noExtField
-                                  , hst_bndrs = hsQTvExplicit qtvs
+                                  , hst_bndrs = qtvs
                                   , hst_body  = theta_ty })
  | otherwise  = theta_ty
  where
@@ -244,7 +244,7 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
                             , con_res_ty = res_ty })
  | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
                                   , hst_xforall = noExtField
-                                  , hst_bndrs = hsQTvExplicit qtvs
+                                  , hst_bndrs = qtvs
                                   , hst_body  = theta_ty })
  | otherwise  = theta_ty
  where
@@ -348,9 +348,9 @@ reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
 reparenLType = fmap reparenType
 
 -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a
-reparenTyVar (UserTyVar x n) = UserTyVar x n
-reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind)
+reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
+reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
 reparenTyVar v@XTyVarBndr{} = v
 
 -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 59c2f818..848acb1f 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -304,14 +304,14 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
        ; return (HsQTvs { hsq_ext = noExtField
                         , hsq_explicit = tvs' }) }
 
-renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
-renameLTyVarBndr (L loc (UserTyVar x (L l n)))
+renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)
+renameLTyVarBndr (L loc (UserTyVar x fl (L l n)))
   = do { n' <- rename n
-       ; return (L loc (UserTyVar x (L l n'))) }
-renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))
+       ; return (L loc (UserTyVar x fl (L l n'))) }
+renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind))
   = do { n' <- rename n
        ; kind' <- renameLKind kind
-       ; return (L loc (KindedTyVar x (L lv n') kind')) }
+       ; return (L loc (KindedTyVar x fl (L lv n') kind')) }
 
 renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
 renameLContext (L loc context) = do
@@ -475,7 +475,7 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
                             , con_res_ty = res_ty
                             , con_doc = mbldoc }) = do
       lnames'   <- mapM renameL lnames
-      ltyvars'  <- renameLHsQTyVars ltyvars
+      ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
       details'  <- renameDetails details
       res_ty'   <- renameLType res_ty
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index a939dfbd..cbfea762 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -60,8 +60,8 @@ specializeTyVarBndrs bndrs typs =
     specialize $ zip bndrs' typs
   where
     bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
-    bname (UserTyVar _ (L _ name)) = name
-    bname (KindedTyVar _ (L _ name) _) = name
+    bname (UserTyVar _ _ (L _ name)) = name
+    bname (KindedTyVar _ _ (L _ name) _) = name
     bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
 
 
@@ -291,10 +291,10 @@ renameLTypes = mapM renameLType
 renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
 renameContext = renameLTypes
 
-renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
-renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname
-renameBinder (KindedTyVar x lname lkind) =
-  KindedTyVar x <$> located renameName lname <*> located renameType lkind
+renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)
+renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname
+renameBinder (KindedTyVar x fl lname lkind) =
+  KindedTyVar x fl <$> located renameName lname <*> located renameType lkind
 
 -- | Core renaming logic.
 renameName :: (Eq name, SetName name) => name -> Rename name name
@@ -348,7 +348,7 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
 located f (L loc e) = L loc <$> f e
 
 
-tyVarName :: HsTyVarBndr name -> IdP name
-tyVarName (UserTyVar _ name) = unLoc name
-tyVarName (KindedTyVar _ (L _ name) _) = name
+tyVarName :: HsTyVarBndr flag name -> IdP name
+tyVarName (UserTyVar _ _ name) = unLoc name
+tyVarName (KindedTyVar _ _ (L _ name) _) = name
 tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index c172320c..e8670012 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -380,12 +380,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
     , pfdKindSig = fdResultSig
     }
   where
-    mkType :: HsTyVarBndr (GhcPass p) -> HsType (GhcPass p)
-    mkType (KindedTyVar _ (L loc name) lkind) =
+    mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)
+    mkType (KindedTyVar _ _ (L loc name) lkind) =
         HsKindSig noExtField tvar lkind
       where
         tvar = L loc (HsTyVar noExtField NotPromoted (L loc name))
-    mkType (UserTyVar _ name) = HsTyVar noExtField NotPromoted name
+    mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name
 
 
 -- | An instance head that may have documentation and a source location.
diff --git a/html-test/src/Bug679.hs b/html-test/src/Bug679.hs
index dba194c4..0a321ec5 100644
--- a/html-test/src/Bug679.hs
+++ b/html-test/src/Bug679.hs
@@ -13,7 +13,7 @@ $(do
    let methodN = mkName "foo"
 
    methodTy <- [t| $(varT a) -> $(varT a) |]
-   let cla = ClassD [] classN [PlainTV a] [] [SigD methodN methodTy]
+   let cla = ClassD [] classN [PlainTV a ()] [] [SigD methodN methodTy]
  
    -- Note that we are /reusing/ the same type variable 'a' as in the class
    instanceHead <- [t| $(conT classN) (Bar $(varT a)) |]