From 039b2346cd7a9998135636146ea234eb9cc0fbab Mon Sep 17 00:00:00 2001 From: "Dr. ERDI Gergo" Date: Fri, 31 Jan 2014 00:55:50 +0800 Subject: Handle infix vs prefix names correctly everywhere, by explicitly specifying the context The basic idea is that "a" and "+" are either pretty-printed as "a" and "(+)" or "`a`" and "+" --- src/Haddock/Backends/Xhtml.hs | 14 +++---- src/Haddock/Backends/Xhtml/Decl.hs | 32 +++++++-------- src/Haddock/Backends/Xhtml/DocMarkup.hs | 4 +- src/Haddock/Backends/Xhtml/Names.hs | 72 +++++++++++++++++++-------------- 4 files changed, 66 insertions(+), 56 deletions(-) (limited to 'src/Haddock') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 567abced..ac4282fb 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -587,25 +587,25 @@ processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts (ClassDecl {}) -> [keyword "class" <+> b] _ -> [] SigD (TypeSig lnames (L _ _)) -> - map (ppNameMini mdl . nameOccName . getName . unLoc) lnames + map (ppNameMini False mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = [groupTag lvl << docToHtml qual txt] processForMiniSynopsis _ _ _ _ = [] -ppNameMini :: Module -> OccName -> Html -ppNameMini mdl nm = +ppNameMini :: Bool -> Module -> OccName -> Html +ppNameMini is_infix mdl nm = anchor ! [ href (moduleNameUrl mdl nm) , target mainFrameName ] - << ppBinder' False nm + << ppBinder' is_infix nm ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html ppTyClBinderWithVarsMini mdl decl = let n = tcdName decl ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above - in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName + in ppTypeApp n ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName ppModuleContents :: Qualification -> [ExportItem DocName] -> Html @@ -653,10 +653,10 @@ processExport summary _ _ qual (ExportGroup lev id0 doc) processExport summary links unicode qual (ExportDecl decl doc subdocs insts) = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual processExport summary _ _ qual (ExportNoDecl y []) - = processDeclOneLiner summary $ ppDocName qual y + = processDeclOneLiner summary $ ppDocName qual (Just False) y processExport summary _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ - ppDocName qual y +++ parenList (map (ppDocName qual) subs) + ppDocName qual (Just False) y +++ parenList (map (ppDocName qual (Just False)) subs) processExport summary _ _ qual (ExportDoc doc) = nothingIf summary $ docSection_ qual doc processExport summary _ _ _ (ExportModule mdl) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 04f94c49..acde5a0f 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -82,7 +82,6 @@ ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qua | 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 @@ -184,9 +183,7 @@ ppTypeSig summary nms pp_ty unicode = ppTyName :: Name -> Html -ppTyName name - | isNameSym name = parens (ppName name) - | otherwise = ppName name +ppTyName = ppName (Just False) -------------------------------------------------------------------------------- @@ -273,25 +270,28 @@ ppDataBinderWithVars summ decl = -- | Print an application of a DocName and a list of HsTypes ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html ppAppNameTypes n ts unicode qual = - ppTypeApp n ts (ppDocName qual) (ppParendType unicode qual) + ppTypeApp n ts (ppDocName qual . Just) (ppParendType unicode qual) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html ppAppDocNameNames summ n ns = - ppTypeApp n ns (ppBinder summ . nameOccName . getName) ppTyName - + ppTypeApp n ns ppDN ppTyName + where + ppDN is_infix = ppBinderFixity is_infix summ . nameOccName . getName + ppBinderFixity True = ppBinderInfix + ppBinderFixity False = ppBinder -- | General printing of type applications -ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html +ppTypeApp :: DocName -> [a] -> (Bool -> DocName -> Html) -> (a -> Html) -> Html ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n - opApp = ppT t1 <+> ppDN n <+> ppT t2 + opApp = ppT t1 <+> ppDN True n <+> ppT t2 -ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) +ppTypeApp n ts ppDN ppT = ppDN False n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- @@ -346,9 +346,8 @@ ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = hsep (map (ppDocName qual) vars1) <+> arrow unicode <+> - hsep (map (ppDocName qual) vars2) - + fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + ppVars = hsep . map (ppDocName qual (Just False)) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification @@ -557,7 +556,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual <+> darrow unicode +++ toHtml " ") where ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " + Explicit -> forallSymbol unicode <+> hsep (map (ppName (Just False)) tvs) <+> toHtml ". " Implicit -> noHtml @@ -721,7 +720,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q name +ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q (Just False) name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = @@ -749,8 +748,7 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where - ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op - occ = nameOccName . getName . unLoc $ op + ppr_op = ppLDocName qual (Just True) op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index ca963f48..69174e96 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -80,12 +80,12 @@ parHtmlMarkup qual ppId = Markup { -- ugly extra whitespace with some browsers). FIXME: Does this still apply? docToHtml :: Qualification -> Doc DocName -> Html docToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual (ppDocName qual) + where fmt = parHtmlMarkup qual (ppDocName qual Nothing) origDocToHtml :: Qualification -> Doc Name -> Html origDocToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual ppName + where fmt = parHtmlMarkup qual (ppName Nothing) rdrDocToHtml :: Qualification -> Doc RdrName -> Html diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 280a888c..1bd2cbc4 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -49,57 +49,64 @@ ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName -ppLDocName :: Qualification -> Located DocName -> Html -ppLDocName qual (L _ d) = ppDocName qual d +-- The Bool indicates if it is to be rendered in infix notation +ppLDocName :: Qualification -> Maybe Bool -> Located DocName -> Html +ppLDocName qual is_infix (L _ d) = ppDocName qual is_infix d -ppDocName :: Qualification -> DocName -> Html -ppDocName qual docName = +-- The Bool indicates if it is to be rendered in infix notation +-- Nothing means print it raw, i.e. don't force it to either infix or prefix +-- TODO: instead of Maybe Bool, add a bespoke datatype +ppDocName :: Qualification -> Maybe Bool -> DocName -> Html +ppDocName qual is_infix docName = case docName of Documented name mdl -> - linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl + linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual is_infix name mdl Undocumented name | isExternalName name || isWiredInName name -> - ppQualifyName qual name (nameModule name) - | otherwise -> ppName name + ppQualifyName qual is_infix name (nameModule name) + | otherwise -> ppName is_infix name -- | Render a name depending on the selected qualification mode -ppQualifyName :: Qualification -> Name -> Module -> Html -ppQualifyName qual name mdl = +ppQualifyName :: Qualification -> Maybe Bool -> Name -> Module -> Html +ppQualifyName qual is_infix name mdl = case qual of - NoQual -> ppName name - FullQual -> ppFullQualName mdl name + NoQual -> ppName is_infix name + FullQual -> ppFullQualName is_infix mdl name LocalQual localmdl -> if moduleString mdl == moduleString localmdl - then ppName name - else ppFullQualName mdl name + then ppName is_infix name + else ppFullQualName is_infix mdl name RelativeQual localmdl -> case List.stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x - Just [] -> ppName name + Just [] -> ppName is_infix name -- sub-module, A.B.x -> B.x Just ('.':m) -> toHtml $ m ++ '.' : getOccString name -- some module with same prefix, ABC.x -> ABC.x - Just _ -> ppFullQualName mdl name + Just _ -> ppFullQualName is_infix mdl name -- some other module, D.x -> D.x - Nothing -> ppFullQualName mdl name + Nothing -> ppFullQualName is_infix mdl name AliasedQual aliases localmdl -> case (moduleString mdl == moduleString localmdl, M.lookup mdl aliases) of - (False, Just alias) -> ppQualName alias name - _ -> ppName name + (False, Just alias) -> ppQualName is_infix alias name + _ -> ppName is_infix name -ppFullQualName :: Module -> Name -> Html -ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name +ppFullQualName :: Maybe Bool -> Module -> Name -> Html +ppFullQualName is_infix mdl name = wrapInfix is_infix (getOccName name) qname + where + qname = toHtml $ moduleString mdl ++ '.' : getOccString name -ppQualName :: ModuleName -> Name -> Html -ppQualName mdlName name = - toHtml $ moduleNameString mdlName ++ '.' : getOccString name +ppQualName :: Maybe Bool -> ModuleName -> Name -> Html +ppQualName is_infix mdlName name = wrapInfix is_infix (getOccName name) qname + where + qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name -ppName :: Name -> Html -ppName name = toHtml (getOccString name) +ppName :: Maybe Bool -> Name -> Html +ppName is_infix name = wrapInfix is_infix (getOccName name) $ toHtml (getOccString name) ppBinder :: Bool -> OccName -> Html @@ -116,12 +123,17 @@ ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] ppBinder' :: Bool -> OccName -> Html -- The Bool indicates if it is to be rendered in infix notation -ppBinder' is_infix n = wrap $ ppOccName n +ppBinder' is_infix n = wrapInfix (Just is_infix) n $ ppOccName n + +wrapInfix :: Maybe Bool -> OccName -> Html -> Html +wrapInfix Nothing _ = id +wrapInfix (Just is_infix) n | is_star_kind = id + | is_infix && not is_sym = quote + | not is_infix && is_sym = parens + | otherwise = id where - wrap | is_infix && not is_sym = quote - | not is_infix && is_sym = parens - | otherwise = id - is_sym = isVarSym n || isConSym n + is_sym = isSymOcc n + is_star_kind = isTcOcc n && occNameString n == "*" linkId :: Module -> Maybe Name -> Html -> Html linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) -- cgit v1.2.3