From c3eb3f0581f69e816f9453b1747a9f2a3ba02bb9 Mon Sep 17 00:00:00 2001
From: Simon Jakobi <simon.jakobi@gmail.com>
Date: Thu, 19 Jul 2018 13:36:45 +0200
Subject: tyThingToLHsDecl: Preserve type synonyms that contain a forall (#880)
* tyThingToLHsDecls: Preserve type synonyms that contain a forall
Fixes #879.
* Add Note [Invariant: Never expand type synonyms]
* Clarify Note [Invariant: Never expand type synonyms]
---
haddock-api/src/Haddock/Convert.hs | 48 ++++++++++++++++++++++++++++++++++++--
1 file changed, 46 insertions(+), 2 deletions(-)
(limited to 'haddock-api')
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
--
cgit v1.2.3