diff options
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 33 |
1 files changed, 19 insertions, 14 deletions
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) |