From 8459c600e0f6da3f85abefdefe651bbe3ed3da4a Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Sat, 19 Jan 2019 15:59:19 -0500
Subject: Visible dependent quantification (#16326) changes

---
 haddock-api/src/Haddock/Convert.hs | 33 +++++++++++++++++++--------------
 1 file changed, 19 insertions(+), 14 deletions(-)

(limited to 'haddock-api/src/Haddock/Convert.hs')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index f3c40be1..fa904e4b 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -610,12 +610,13 @@ synifyType _ vs (AppTy t1 t2) = let
   s1 = synifyType WithinType vs t1
   s2 = synifyType WithinType vs t2
   in noLoc $ HsAppTy noExt s1 s2
-synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s vs funty
+synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty
 synifyType _ vs       (FunTy VisArg t1 t2) = let
   s1 = synifyType WithinType vs t1
   s2 = synifyType WithinType vs t2
   in noLoc $ HsFunTy noExt s1 s2
-synifyType s vs forallty@(ForAllTy _tv _ty) = synifyForAllType s vs forallty
+synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
+  synifyForAllType s argf vs forallty
 
 synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t
 synifyType s vs (CastTy t _) = synifyType s vs t
@@ -625,16 +626,18 @@ synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"
 -- an 'HsType'
 synifyForAllType
   :: SynifyTypeState  -- ^ what to do with the 'forall'
+  -> ArgFlag          -- ^ the visibility of the @forall@
   -> [TyVar]          -- ^ free variables in the type to convert
   -> Type             -- ^ the forall type to convert
   -> LHsType GhcRn
-synifyForAllType s vs ty =
-  let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty
+synifyForAllType s argf vs ty =
+  let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty
       sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
                       , hst_xqual = noExt
                       , hst_body = synifyType WithinType (tvs' ++ vs) tau }
 
-      sTy = HsForAllTy { hst_bndrs = sTvs
+      sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf
+                       , hst_bndrs = sTvs
                        , hst_xforall = noExt
                        , hst_body  = noLoc sPhi }
 
@@ -677,7 +680,8 @@ implicitForAll tycons vs tvs ctx synInner tau
        = HsQualTy { hst_ctxt = synifyCtx ctx
                   , hst_xqual = noExt
                   , hst_body = synInner (tvs' ++ vs) tau }
-  sTy = HsForAllTy { hst_bndrs = sTvs
+  sTy = HsForAllTy { hst_fvf = ForallInvis
+                   , hst_bndrs = sTvs
                    , hst_xforall = noExt
                    , hst_body = noLoc sPhi }
 
@@ -825,21 +829,22 @@ 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.
+-- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms.
 --
 -- See Note [Invariant: Never expand type synonyms]
-tcSplitSigmaTyPreserveSynonyms :: Type -> ([TyVar], ThetaType, Type)
-tcSplitSigmaTyPreserveSynonyms ty =
-    case tcSplitForAllTysPreserveSynonyms ty of
+tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], 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]
-tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type)
-tcSplitForAllTysPreserveSynonyms ty = split ty ty []
+tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type)
+tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty []
   where
-    split _       (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs)
-    split orig_ty _                          tvs = (reverse tvs, orig_ty)
+    split _       (ForAllTy (Bndr tv argf) ty') tvs
+      | argf `sameVis` supplied_argf                = split ty' ty' (tv:tvs)
+    split orig_ty _                             tvs = (reverse tvs, orig_ty)
 
 -- | See Note [Invariant: Never expand type synonyms]
 tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
-- 
cgit v1.2.3