aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs25
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs42
-rw-r--r--haddock-api/src/Haddock/Convert.hs66
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs18
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs18
-rw-r--r--haddock-api/src/Haddock/Types.hs6
8 files changed, 123 insertions, 68 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.
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 16:52:54 +0000