diff options
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 48 |
1 files changed, 46 insertions, 2 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 8b227c50..7595f798 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -31,7 +31,7 @@ import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) -import TcType ( tcSplitSigmaTy ) +import TcType import TyCon import Type import TyCoRep @@ -515,7 +515,7 @@ synifyType _ (FunTy t1 t2) = let s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = - let (tvs, ctx, tau) = tcSplitSigmaTy forallty + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_body = synifyType WithinType tau } in case s of @@ -610,3 +610,47 @@ synifyFamInst fi opaque = do ts' = synifyTypes ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) + +{- +Note [Invariant: Never expand type synonyms] + +In haddock, we never want to expand a type synonym that may be presented to the +user, as we want to keep the link to the abstraction captured in the synonym. + +All code in Haddock.Convert must make sure that this invariant holds. + +See https://github.com/haskell/haddock/issues/879 for a bug where this +invariant didn't hold. +-} + +-- | A version of 'TcType.tcSplitSigmaTy' that preserves type synonyms. +-- +-- See Note [Invariant: Never expand type synonyms] +tcSplitSigmaTyPreserveSynonyms :: Type -> ([TyVar], ThetaType, Type) +tcSplitSigmaTyPreserveSynonyms ty = + case tcSplitForAllTysPreserveSynonyms ty of + (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of + (theta, tau) -> (tvs, theta, tau) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type) +tcSplitForAllTysPreserveSynonyms ty = split ty ty [] + where + split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) +tcSplitPhiTyPreserveSynonyms ty0 = split ty0 [] + where + split ty ts + = case tcSplitPredFunTyPreserveSynonyms_maybe ty of + Just (pred_, ty') -> split ty' (pred_:ts) + Nothing -> (reverse ts, ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type) +tcSplitPredFunTyPreserveSynonyms_maybe (FunTy arg res) + | isPredTy arg = Just (arg, res) +tcSplitPredFunTyPreserveSynonyms_maybe _ + = Nothing |