From 7c905816eb12981840efe4136989799db437f357 Mon Sep 17 00:00:00 2001 From: "Dr. ERDI Gergo" Date: Thu, 9 Jan 2014 01:42:55 -0600 Subject: Support for -XPatternSynonyms Signed-off-by: Austin Seipp --- src/Haddock/Backends/LaTeX.hs | 44 +++++++++++++++++++++-- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 71 +++++++++++++++++++++++++++++++------ src/Haddock/Backends/Xhtml/Names.hs | 23 +++++++----- src/Haddock/Convert.hs | 12 ++++++- src/Haddock/GhcUtils.hs | 4 +++ src/Haddock/Interface/Create.hs | 24 +++++++------ src/Haddock/Interface/Rename.hs | 9 +++++ 8 files changed, 156 insertions(+), 33 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 4a30a168..94adc558 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -249,6 +249,7 @@ declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] SigD (TypeSig lnames _) -> map unLoc lnames + SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -291,6 +292,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of -- Family instances happen via FamInst now TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -345,6 +348,33 @@ ppFunSig loc doc docnames typ unicode = where names = map getName docnames +ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName + -> HsPatSynDetails (LHsType DocName) -> LHsType DocName + -> LHsContext DocName -> LHsContext DocName + -> Bool -> LaTeX +ppLPatSig loc doc docname args typ prov req unicode = + ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode + +ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName + -> HsPatSynDetails (HsType DocName) -> HsType DocName + -> HsContext DocName -> HsContext DocName + -> Bool -> LaTeX +ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) + where + pref1 = hsep [ keyword "pattern" + , pp_ctx prov + , pp_head + , dcolon unicode + , pp_ctx req + , ppType unicode typ + ] + + pp_head = case args of + PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs + InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right] + + pp_type = ppParendType unicode + pp_ctx ctx = ppContext ctx unicode ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) @@ -914,9 +944,16 @@ ppr_fun_ty ctxt_prec ty1 ty2 unicode ppBinder :: OccName -> LaTeX ppBinder n - | isVarSym n = parens $ ppOccName n - | otherwise = ppOccName n + | isInfixName n = parens $ ppOccName n + | otherwise = ppOccName n +ppBinderInfix :: OccName -> LaTeX +ppBinderInfix n + | isInfixName n = ppOccName n + | otherwise = quotes $ ppOccName n + +isInfixName :: OccName -> Bool +isInfixName n = isVarSym n || isConSym n ppSymName :: Name -> LaTeX ppSymName name @@ -953,6 +990,9 @@ ppLDocName (L _ d) = ppDocName d ppDocBinder :: DocName -> LaTeX ppDocBinder = ppBinder . nameOccName . getName +ppDocBinderInfix :: DocName -> LaTeX +ppDocBinderInfix = ppBinderInfix . nameOccName . getName + ppName :: Name -> LaTeX ppName = ppOccName . nameOccName diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index d61478a8..567abced 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -598,7 +598,7 @@ ppNameMini :: Module -> OccName -> Html ppNameMini mdl nm = anchor ! [ href (moduleNameUrl mdl nm) , target mainFrameName ] - << ppBinder' nm + << ppBinder' False nm ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 91e6871d..04f94c49 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -30,6 +30,7 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse ) import qualified Data.Map as Map import Data.Maybe +import Data.Monoid ( mempty ) import Text.XHtml hiding ( name, title, p, quote ) import GHC @@ -40,21 +41,69 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual - SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty unicode qual + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" +ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [Located DocName] -> LHsType DocName -> Bool -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty unicode qual = + ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) unicode qual + ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName -> Bool -> Qualification -> Html ppFunSig summary links loc doc docnames typ unicode qual = + ppSigLike summary links loc mempty doc docnames (typ, pp_typ) unicode qual + where + pp_typ = ppType unicode qual typ + +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + Located DocName -> + HsPatSynDetails (LHsType DocName) -> LHsType DocName -> + LHsContext DocName -> LHsContext DocName -> + Bool -> Qualification -> Html +ppLPatSig summary links loc doc lname args typ prov req unicode qual = + ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode qual + +ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + DocName -> + HsPatSynDetails (HsType DocName) -> HsType DocName -> + HsContext DocName -> HsContext DocName -> + Bool -> Qualification -> Html +ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qual + | summary = pref1 + | otherwise = topDeclElem links loc [docname] pref1 +++ docSection qual doc + where + -- pref1 = leader <+> ppTypeSig summary occnames pp_typ unicode + pref1 = hsep [ toHtml "pattern" + , pp_cxt prov + , pp_head + , dcolon unicode + , pp_cxt req + , ppType unicode qual typ + ] + pp_head = case args of + PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs + InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] + + pp_cxt cxt = ppContext cxt unicode qual + pp_type = ppParendType unicode qual + + occname = nameOccName . getName $ docname + +ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> + [DocName] -> (HsType DocName, Html) -> Bool -> Qualification -> Html +ppSigLike summary links loc leader doc docnames (typ, pp_typ) unicode qual = ppTypeOrFunSig summary links loc docnames typ doc - ( ppTypeSig summary occnames typ unicode qual + ( leader <+> ppTypeSig summary occnames pp_typ unicode , concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) @@ -127,9 +176,9 @@ ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvar ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> [OccName] -> HsType DocName -> Bool -> Qualification -> Html -ppTypeSig summary nms ty unicode qual = - concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty +ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html +ppTypeSig summary nms pp_ty unicode = + concatHtml htmlNames <+> dcolon unicode <+> pp_ty where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms @@ -465,7 +514,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of char '}') InfixCon arg1 arg2 -> (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppBinder summary occ, ppLParendType unicode qual arg2], + ppBinderInfix summary occ, ppLParendType unicode qual arg2], noHtml, noHtml) ResTyGADT resTy -> case con_details con of @@ -526,7 +575,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) InfixCon arg1 arg2 -> hsep [header_ unicode qual +++ ppLParendType unicode qual arg1, - ppBinder False occ, + ppBinderInfix False occ, ppLParendType unicode qual arg2] ResTyGADT resTy -> case con_details con of diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 2f2b82ed..280a888c 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, - ppBinder, ppBinder', + ppBinder, ppBinderInfix, ppBinder', ppModule, ppModuleRef, ppIPName, linkId @@ -105,16 +105,23 @@ ppName name = toHtml (getOccString name) ppBinder :: Bool -> OccName -> Html -- The Bool indicates whether we are generating the summary, in which case -- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n +ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' False n ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' n + << ppBinder' False n +ppBinderInfix :: Bool -> OccName -> Html +ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' True n +ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' True n -ppBinder' :: OccName -> Html -ppBinder' n - | isVarSym n = parens $ ppOccName n - | otherwise = ppOccName n - +ppBinder' :: Bool -> OccName -> Html +-- The Bool indicates if it is to be rendered in infix notation +ppBinder' is_infix n = wrap $ ppOccName n + where + wrap | is_infix && not is_sym = quote + | not is_infix && is_sym = parens + | otherwise = id + is_sym = isVarSym n || isConSym n linkId :: Module -> Maybe Name -> Html -> Html linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 0f7e5b9c..66497783 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -27,7 +27,9 @@ import Var import Class import TyCon import CoAxiom +import ConLike import DataCon +import PatSyn import BasicTypes ( TupleSort(..) ) import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon ) @@ -85,9 +87,17 @@ tyThingToLHsDecl t = noLoc $ case t of ACoAxiom ax -> synifyAxiom ax -- a data-constructor alone just gets rendered as a function: - ADataCon dc -> SigD (TypeSig [synifyName dc] + AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) + AConLike (PatSynCon ps) -> + let (_, _, (req_theta, prov_theta)) = patSynSig ps + in SigD $ PatSynSig (synifyName ps) + (fmap (synifyType WithinType) (patSynTyDetails ps)) + (synifyType WithinType (patSynType ps)) + (synifyCtx req_theta) + (synifyCtx prov_theta) + synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 467541fc..a8a4f1c9 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -76,6 +76,9 @@ isNameSym = isSymOcc . nameOccName isVarSym :: OccName -> Bool isVarSym = isLexVarSym . occNameFS +isConSym :: OccName -> Bool +isConSym = isLexConSym . occNameFS + getMainDeclBinder :: HsDecl name -> [name] getMainDeclBinder (TyClD d) = [tcdName d] @@ -115,6 +118,7 @@ sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] sigNameNoLoc (SpecSig n _ _) = [unLoc n] sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n] diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 6c20f00b..6e85ad16 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -31,6 +31,7 @@ import Data.Ord import Control.Applicative import Control.DeepSeq import Control.Monad +import qualified Data.Foldable as F import qualified Data.Traversable as T import qualified Packages @@ -327,6 +328,9 @@ typeDocs d = let docs = go 0 in case d of SigD (TypeSig _ ty) -> docs (unLoc ty) + SigD (PatSynSig _ arg_tys ty req prov) -> + let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ] + in F.foldMap (docs . unLoc) allTys ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty @@ -345,7 +349,7 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ + defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_ sigs = mkDecls tcdSigs SigD class_ ats = mkDecls tcdATs (TyClD . FamDecl) class_ @@ -360,13 +364,13 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup ungroup :: HsGroup Name -> [LHsDecl Name] ungroup group_ = mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls hs_instds InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ ++ - mkDecls (valbinds . hs_valds) ValD group_ + mkDecls hs_derivds DerivD group_ ++ + mkDecls hs_defds DefD group_ ++ + mkDecls hs_fords ForD group_ ++ + mkDecls hs_docs DocD group_ ++ + mkDecls hs_instds InstD group_ ++ + mkDecls (typesigs . hs_valds) SigD group_ ++ + mkDecls (map snd . valbinds . hs_valds) ValD group_ where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs typesigs _ = error "expected ValBindsOut" @@ -718,8 +722,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names - f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 9a4041ee..b4a7e19a 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -398,6 +398,15 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames ltype' <- renameLType ltype return (TypeSig lnames' ltype') + PatSynSig lname args ltype lreq lprov -> do + lname' <- renameL lname + args' <- case args of + PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs + InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright + ltype' <- renameLType ltype + lreq' <- renameLContext lreq + lprov' <- renameLContext lprov + return $ PatSynSig lname' args' ltype' lreq' lprov' -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" -- cgit v1.2.3