From 21e4f3fa6f73a9b25f3deed80da0e56024238ea5 Mon Sep 17 00:00:00 2001 From: mynguyen Date: Tue, 17 Jul 2018 18:20:12 -0400 Subject: Visible kind application haddock update --- haddock-api/src/Haddock/Backends/Hoogle.hs | 1 + haddock-api/src/Haddock/Backends/LaTeX.hs | 22 ++++++++++++++++++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 19 ++++++++++++++++--- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 5 +++-- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/GhcUtils.hs | 2 ++ haddock-api/src/Haddock/Interface/Create.hs | 21 ++++++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 21 +++++++++++++++------ haddock-api/src/Haddock/Interface/Specialize.hs | 3 +++ haddock-api/src/Haddock/Types.hs | 4 +++- 10 files changed, 76 insertions(+), 24 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index b3b46a47..16ec582e 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -76,6 +76,7 @@ dropHsDocTy = f 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) + f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b) f (HsFunTy x a b) = HsFunTy x (g a) (g b) f (HsListTy x a) = HsListTy x (g a) f (HsTupleTy x a b) = HsTupleTy x a (map g b) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 1222b3f1..12256a00 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -345,7 +345,7 @@ ppFamDecl doc instances decl unicode = ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts } }) - = hsep [ ppAppNameTypes n (map unLoc ts) unicode + = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) ] @@ -908,6 +908,11 @@ ppAppDocNameTyVarBndrs unicode n vs = ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) +ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX +ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode + = ppTypeApp n args ppDocName (ppLHsTypeArg unicode) +ppAppNameTypeArgs n args unicode + = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX @@ -926,7 +931,6 @@ ppTypeApp n (t1:t2:rest) ppDN ppT ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) - ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- @@ -997,6 +1001,12 @@ ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode +ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX +ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty +ppLHsTypeArg unicode (HsTypeArg ki) = atSign unicode <> + ppLParendType unicode ki +ppLHsTypeArg _ (HsArgPar _) = text "" + ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = @@ -1046,6 +1056,9 @@ ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLTyp ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] +ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode + = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode] + ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode where @@ -1059,7 +1072,7 @@ ppr_mono_ty (HsParTy _ ty) unicode ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_" +ppr_mono_ty (HsWildCardTy _) _ = text "\\_" ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1315,12 +1328,13 @@ quote :: LaTeX -> LaTeX quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX +dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") starSymbol unicode = text (if unicode then "★" else "*") +atSign unicode = text (if unicode then "@" else "@") dot :: LaTeX dot = char '.' diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 819a4747..9952721c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -315,7 +315,7 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts } }) - = ( ppAppNameTypes n (map unLoc ts) unicode qual + = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing , [] @@ -418,6 +418,11 @@ ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Ht ppAppNameTypes n ts unicode qual = ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) +ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Unicode -> Qualification -> Html +ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) u q + = ppTypeApp n args (\p -> ppDocName q p True) (ppLHsTypeArg u q HideEmptyContexts) +ppAppNameTypeArgs n args u q + = (ppDocName q Prefix True n) <+> hsep (map (ppLHsTypeArg u q HideEmptyContexts) args) -- | General printing of type applications ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html @@ -430,7 +435,6 @@ ppTypeApp n (t1:t2:rest) ppDN ppT ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) - ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- @@ -1103,6 +1107,11 @@ ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts +ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html +ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty +ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg ki) = atSign unicode <> + ppLParendType unicode qual emptyCtxts ki +ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppDocName qual Raw False name @@ -1195,6 +1204,10 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _ = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ] +ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ + = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts + , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts] + ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts where @@ -1212,7 +1225,7 @@ ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts = ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 62781fd0..c3acb6df 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -22,6 +22,7 @@ module Haddock.Backends.Xhtml.Utils ( braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + atSign, hsep, vcat, @@ -186,12 +187,12 @@ ubxparens :: Html -> Html ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" -dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow unicode = toHtml (if unicode then "→" else "->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" - +atSign unicode = toHtml (if unicode then "@" else "@") dot :: Html dot = toHtml "." diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 291af8de..5312bfc7 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -125,7 +125,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) , feqn_tycon = name , feqn_bndrs = Nothing -- this must change eventually - , feqn_pats = annot_typats + , feqn_pats = map HsValArg annot_typats , feqn_fixity = Prefix , feqn_rhs = hs_rhs } } where diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 7f45bb61..cdaf6ae4 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -264,6 +264,8 @@ reparenTypePrec = go = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) + go p (HsAppKindTy x fun_ty arg_ki) + = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) go p (HsOpTy x ty1 op ty2) = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c72d5f38..c9290ed0 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1076,8 +1076,8 @@ extractDecl declMap name decl TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) - else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap @@ -1116,8 +1116,7 @@ extractDecl declMap name decl O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" O.$$ O.nest 4 (O.ppr decl) - -extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractPatternSyn nm t tvs cons = case filter matches cons of [] -> error "extractPatternSyn: constructor pattern not found" @@ -1145,9 +1144,13 @@ extractPatternSyn nm t tvs cons = data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] +extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" @@ -1163,7 +1166,11 @@ extractRecSel nm t tvs (L _ con : rest) = data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index c6160b2b..57e6d699 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -183,6 +183,13 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType +renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI) +renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty + ; return $ HsValArg ty' } +renameLTypeArg (HsTypeArg ki) = do { ki' <- renameLKind ki + ; return $ HsTypeArg ki' } +renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp + renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType @@ -238,6 +245,11 @@ renameType t = case t of b' <- renameLType b return (HsAppTy NoExt a' b') + HsAppKindTy _ a b -> do + a' <- renameLType a + b' <- renameLKind b + return (HsAppKindTy NoExt a' b') + HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b @@ -274,7 +286,7 @@ renameType t = case t of HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ s -> renameHsSpliceTy s - HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsWildCardTy a -> pure (HsWildCardTy a) -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: @@ -309,9 +321,6 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo -renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name)) - renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName @@ -603,7 +612,7 @@ renameTyFamInstEqn eqn , feqn_rhs = rhs }) = do { tc' <- renameL tc ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs - ; pats' <- mapM renameLType pats + ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' @@ -640,7 +649,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_rhs = defn }) = do { tc' <- renameL tc ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs - ; pats' <- mapM renameLType pats + ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 5ab3a7ee..6fd528af 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -255,6 +255,7 @@ renameType (HsQualTy x lctxt lt) = renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la +renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt @@ -280,6 +281,8 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType +renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn) +renameLKind = renameLType renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index c1b8328d..2f5d0a9a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -674,6 +675,7 @@ type instance XQualTy DocNameI = NoExt type instance XTyVar DocNameI = NoExt type instance XStarTy DocNameI = NoExt type instance XAppTy DocNameI = NoExt +type instance XAppKindTy DocNameI = NoExt type instance XFunTy DocNameI = NoExt type instance XListTy DocNameI = NoExt type instance XTupleTy DocNameI = NoExt @@ -689,7 +691,7 @@ type instance XRecTy DocNameI = NoExt type instance XExplicitListTy DocNameI = NoExt type instance XExplicitTupleTy DocNameI = NoExt type instance XTyLit DocNameI = NoExt -type instance XWildCardTy DocNameI = HsWildCardInfo +type instance XWildCardTy DocNameI = NoExt type instance XXType DocNameI = NewHsTypeX type instance XUserTyVar DocNameI = NoExt -- cgit v1.2.3