From 37a1603cd81a117d107a8468f342a0f56af6f64e Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Fri, 19 Dec 2014 08:16:30 +0100 Subject: Follow changes from #6018 --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 42 +++++++++++++++++++++++--- haddock-api/src/Haddock/Convert.hs | 42 +++++++++++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 34 +++++++++++++++++---- 3 files changed, 96 insertions(+), 22 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 69393a37..bc16bdcd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -257,12 +257,32 @@ ppFamilyKind _ _ Nothing = noHtml ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdKindSig = mkind }) + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) unicode qual = - ppFamilyInfo associated info <+> - ppFamDeclBinderWithVars summary d <+> - ppFamilyKind unicode qual mkind - + (case info of + OpenTypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ClosedTypeFamily _ + -> keyword "type family" + ) <+> + + ppFamDeclBinderWithVars summary d <+> + + (case result of + NoSig -> noHtml + KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + ) <+> + + (case injectivity of + Nothing -> noHtml + Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn + ) ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName -> Html @@ -271,6 +291,11 @@ ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> ppFamilyKind unicode qual pfdKindSig +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html +ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = + char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> + hsep (map (ppLDocName qual Raw) rhs) + ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> @@ -913,6 +938,13 @@ ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html +ppHsTyVarBndr _ qual (UserTyVar name ) = + ppDocName qual Raw False name +ppHsTyVarBndr unicode qual (KindedTyVar name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 24947876..cf8b8243 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -26,7 +26,7 @@ import Data.List( partition ) import DataCon import FamInstEnv import HsSyn -import Kind ( splitKindFunTys, synTyConResKind, isKind ) +import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) @@ -37,6 +37,7 @@ import TypeRep import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) import Unique ( getUnique ) +import Util ( filterByList ) import Var import Haddock.Types @@ -166,7 +167,8 @@ synifyTyCon coax tc | isTypeFamilyTyCon tc = case famTyConFlav_maybe tc of Just rhs -> - let info = case rhs of + let resultVar = famTcResVar tc + info = case rhs of OpenSynFamilyTyCon -> return OpenTypeFamily ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) @@ -178,21 +180,25 @@ synifyTyCon coax tc AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily Nothing in info >>= \i -> - return (FamDecl - (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = - Just (synifyKindSig (synTyConResKind tc)) - })) + return (FamDecl (FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + })) Nothing -> Left "synifyTyCon: impossible open type synonym?" | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - Nothing) --always kind '*' + FamDecl (FamilyDecl DataFamily (synifyName tc) + (synifyTyVars (tyConTyVars tc)) + (noLoc NoSig) -- always kind '*' + Nothing) -- no injectivity _ -> Left "synifyTyCon: impossible open data type?" | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc @@ -243,6 +249,20 @@ synifyTyCon coax tc , tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity + -> Maybe (LInjectivityAnn Name) +synifyInjectivityAnn Nothing _ _ = Nothing +synifyInjectivityAnn _ _ NotInjective = Nothing +synifyInjectivityAnn (Just lhs) tvs (Injective inj) = + let rhs = map (noLoc . tyVarName) (filterByList inj tvs) + in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs + +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name +synifyFamilyResultSig Nothing kind = + noLoc $ KindSig (synifyKindSig kind) +synifyFamilyResultSig (Just name) kind = + noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind)) + -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 30074e4f..6ec1f2c5 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -176,6 +176,25 @@ renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind +renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig (L loc NoSig) + = return (L loc NoSig) +renameFamilyResultSig (L loc (KindSig ki)) + = do { ki' <- renameLKind ki + ; return (L loc (KindSig ki')) } +renameFamilyResultSig (L loc (TyVarSig bndr)) + = do { bndr' <- renameLTyVarBndr bndr + ; return (L loc (TyVarSig bndr')) } + +renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) + = do { lhs' <- renameL lhs + ; rhs' <- mapM renameL rhs + ; return (L loc (InjectivityAnn lhs' rhs')) } + +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) + -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of @@ -343,13 +362,16 @@ renameTyClD d = case d of renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdKindSig = tckind }) = do - info' <- renameFamilyInfo info - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - tckind' <- renameMaybeLKind tckind + , fdTyVars = ltyvars, fdResultSig = result + , fdInjectivityAnn = injectivity }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + result' <- renameFamilyResultSig result + injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdKindSig = tckind' }) + , fdTyVars = ltyvars', fdResultSig = result' + , fdInjectivityAnn = injectivity' }) renamePseudoFamilyDecl :: PseudoFamilyDecl Name -- cgit v1.2.3