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/Backends/HaddockDB.hs | 15 ++++++----
haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +-
haddock-api/src/Haddock/Backends/LaTeX.hs | 16 +++++++---
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 39 +++++++++++++++----------
haddock-api/src/Haddock/Convert.hs | 33 ++++++++++++---------
haddock-api/src/Haddock/GhcUtils.hs | 11 +++----
haddock-api/src/Haddock/Interface/Rename.hs | 5 ++--
haddock-api/src/Haddock/Interface/Specialize.hs | 6 ++--
haddock-api/src/Haddock/Utils.hs | 4 +--
9 files changed, 80 insertions(+), 51 deletions(-)
(limited to 'haddock-api/src/Haddock')
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs
index 0bdc9057..6c48804a 100644
--- a/haddock-api/src/Haddock/Backends/HaddockDB.hs
+++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs
@@ -104,17 +104,22 @@ ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
hsep (map ppHsAType b)) context)
ppHsType :: HsType -> Doc
-ppHsType (HsForAllType Nothing context htype) =
+ppHsType (HsForAllType _ Nothing context htype) =
hsep [ ppHsContext context, text "=>", ppHsType htype]
-ppHsType (HsForAllType (Just tvs) [] htype) =
- hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
-ppHsType (HsForAllType (Just tvs) context htype) =
- hsep (text "forall" : map ppHsName tvs ++ text "." :
+ppHsType (HsForAllType fvf (Just tvs) [] htype) =
+ hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :
+ [ppHsType htype])
+ppHsType (HsForAllType fvf (Just tvs) context htype) =
+ hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :
ppHsContext context : text "=>" : [ppHsType htype])
ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b]
ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
ppHsType t = ppHsBType t
+ppHsForAllSeparator :: ForallVisFlag -> Doc
+ppHsForAllSeparator ForallVis = text "->"
+ppHsForAllSeparator ForallInvis = text "."
+
ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9e3186e5..6aac2f08 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -72,7 +72,7 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- f (HsForAllTy x a e) = HsForAllTy x a (g e)
+ f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e)
f (HsQualTy x a e) = HsQualTy x a (g e)
f (HsBangTy x a b) = HsBangTy x a (g b)
f (HsAppTy x a b) = HsAppTy x (g a) (g b)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index dc083024..9e2e52c3 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -477,9 +477,10 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
- do_args _n leader (HsForAllTy _ tvs ltype)
+ do_args _n leader (HsForAllTy _ fvf tvs ltype)
= [ ( decltt leader
- , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
+ , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++
+ [ppForAllSeparator unicode fvf]))
<+> ppLType unicode ltype
) ]
do_args n leader (HsQualTy _ lctxt ltype)
@@ -508,6 +509,12 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
gadtOpen = text "\\{"
+ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX
+ppForAllSeparator unicode fvf =
+ case fvf of
+ ForallVis -> text "\\ " <> arrow unicode
+ ForallInvis -> dot
+
ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
ppTypeSig nms ty unicode =
hsep (punctuate comma $ map ppSymName nms)
@@ -1028,8 +1035,9 @@ ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
-ppr_mono_ty (HsForAllTy _ tvs ty) unicode
- = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode
+ = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <>
+ ppForAllSeparator unicode fvf
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext ctxt unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 238c584f..1a0db153 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -151,10 +151,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
do_largs n leader (L _ t) = do_args n leader t
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
- do_args n leader (HsForAllTy _ tvs ltype)
+ do_args n leader (HsForAllTy _ fvf tvs ltype)
= do_largs n leader' ltype
where
- leader' = leader <+> ppForAll tvs unicode qual
+ leader' = leader <+> ppForAll tvs unicode qual fvf
do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
@@ -189,14 +189,21 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
-ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
-ppForAll tvs unicode qual =
+ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> ForallVisFlag
+ -> Html
+ppForAll tvs unicode qual fvf =
case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
[] -> noHtml
- ts -> forallSymbol unicode <+> hsep ts +++ dot
+ ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf
where ppKTv n k = parens $
ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k
+ppForAllSeparator :: Unicode -> ForallVisFlag -> Html
+ppForAllSeparator unicode fvf =
+ case fvf of
+ ForallVis -> spaceHtml +++ arrow unicode
+ ForallInvis -> dot
+
ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
ppFixities [] _ = noHtml
ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
@@ -1133,16 +1140,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp
hasNonEmptyContext :: LHsType name -> Bool
hasNonEmptyContext t =
case unLoc t of
- HsForAllTy _ _ s -> hasNonEmptyContext s
- HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
- HsFunTy _ _ s -> hasNonEmptyContext s
+ HsForAllTy _ _ _ s -> hasNonEmptyContext s
+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsFunTy _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty :: LHsType name -> Bool
isFirstContextEmpty t =
case unLoc t of
- HsForAllTy _ _ s -> isFirstContextEmpty s
- HsQualTy _ cxt _ -> null (unLoc cxt)
- HsFunTy _ _ s -> isFirstContextEmpty s
+ HsForAllTy _ _ _ s -> isFirstContextEmpty s
+ HsQualTy _ cxt _ -> null (unLoc cxt)
+ HsFunTy _ _ s -> isFirstContextEmpty s
_ -> False
@@ -1152,16 +1159,18 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
-ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
-ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
+ppForAllPart :: Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr DocNameI] -> Html
+ppForAllPart unicode qual fvf tvs =
+ hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++
+ ppForAllSeparator unicode fvf
ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty (HsForAllTy _ tvs ty) unicode qual emptyCtxts
- = ppForAllPart unicode qual tvs <+> ppr_mono_lty ty unicode qual emptyCtxts
+ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts
+ = ppForAllPart unicode qual fvf tvs <+> ppr_mono_lty ty unicode qual emptyCtxts
ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
= ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
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)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 63303bfa..1ed93b3c 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -48,7 +48,6 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
-
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -177,7 +176,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
+ | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
+ , hst_xforall = NoExt
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
@@ -209,7 +209,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
+ | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
+ , hst_xforall = NoExt
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
@@ -273,8 +274,8 @@ reparenTypePrec = go
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
go p (HsIParamTy x n ty)
= paren p PREC_CTX $ HsIParamTy x n (reparenLType ty)
- go p (HsForAllTy x tvs ty)
- = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty)
+ go p (HsForAllTy x fvf tvs ty)
+ = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty)
go p (HsQualTy x ctxt ty)
= paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)
go p (HsFunTy x ty1 ty2)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 10b0765d..5ba5d454 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -225,10 +225,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
- HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
+ HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
ltype' <- renameLType ltype
- return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' })
+ return (HsForAllTy { hst_fvf = fvf, hst_xforall = NoExt
+ , hst_bndrs = tyvars', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 6fd528af..e2908af4 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -206,7 +206,7 @@ freeVariables =
everythingWithState Set.empty Set.union query
where
query term ctx = case cast term :: Maybe (HsType GhcRn) of
- Just (HsForAllTy _ bndrs _) ->
+ Just (HsForAllTy _ _ bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
Just (HsTyVar _ _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
@@ -244,8 +244,8 @@ data RenameEnv name = RenameEnv
renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
-renameType (HsForAllTy x bndrs lt) =
- HsForAllTy x
+renameType (HsForAllTy x fvf bndrs lt) =
+ HsForAllTy x fvf
<$> mapM (located renameBinder) bndrs
<*> renameLType lt
renameType (HsQualTy x lctxt lt) =
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index dda42cea..6be82ffd 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -138,8 +138,8 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
= L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype))))
-- The mkEmptySigWcType is suspicious
where
- go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))
- = L loc (HsForAllTy { hst_xforall = noExt
+ go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))
+ = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExt
, hst_bndrs = tvs, hst_body = go ty })
go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
= L loc (HsQualTy { hst_xqual = noExt
--
cgit v1.2.3