From 2af56ba08c876f39a066468d427e897f7329cc37 Mon Sep 17 00:00:00 2001 From: Gert-Jan Bottu Date: Sun, 5 Apr 2020 11:16:56 +0200 Subject: Explicit Specificity Support for Haddock --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 25 +++++++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 42 +++++++++++----- haddock-api/src/Haddock/Convert.hs | 66 ++++++++++++++++--------- haddock-api/src/Haddock/GhcUtils.hs | 18 +++---- haddock-api/src/Haddock/Interface/Rename.hs | 12 ++--- haddock-api/src/Haddock/Interface/Specialize.hs | 18 +++---- haddock-api/src/Haddock/Types.hs | 6 +-- html-test/src/Bug679.hs | 2 +- 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)) |] -- cgit v1.2.3