From 8459c600e0f6da3f85abefdefe651bbe3ed3da4a Mon Sep 17 00:00:00 2001 From: Ryan Scott 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') 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