From 990d54c4e4a119d6d3a9ceae278eb7ca9fd24fce 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]

(cherry picked from commit c3eb3f0581f69e816f9453b1747a9f2a3ba02bb9)
---
 haddock-api/src/Haddock/Convert.hs | 48 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 46 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index bf6fbab0..6eee353b 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
@@ -527,7 +527,7 @@ synifyType _ (FunTy t1 t2) = let
   s2 = synifyType WithinType t2
   in noLoc $ HsFunTy noExt 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_xqual   = noExt
                       , hst_body = synifyType WithinType tau }
@@ -626,3 +626,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