diff options
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 12 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 24 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 4 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Names.hs | 92 |
4 files changed, 66 insertions, 66 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 77ff35b2..35b82a2c 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -587,18 +587,18 @@ processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts (ClassDecl {}) -> [keyword "class" <+> b] _ -> [] SigD (TypeSig lnames (L _ _)) -> - map (ppNameMini False mdl . nameOccName . getName . unLoc) lnames + map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = [groupTag lvl << docToHtml qual txt] processForMiniSynopsis _ _ _ _ = [] -ppNameMini :: Bool -> Module -> OccName -> Html -ppNameMini is_infix mdl nm = +ppNameMini :: Notation -> Module -> OccName -> Html +ppNameMini notation mdl nm = anchor ! [ href (moduleNameUrl mdl nm) , target mainFrameName ] - << ppBinder' is_infix nm + << ppBinder' notation nm ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html @@ -654,10 +654,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 (Just False) y + = processDeclOneLiner summary $ ppDocName qual Prefix y processExport summary _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ - ppDocName qual (Just False) y +++ parenList (map (ppDocName qual (Just False)) subs) + ppDocName qual Prefix y +++ parenList (map (ppDocName qual Prefix) 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 85eee248..72369069 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -183,7 +183,7 @@ ppTypeSig summary nms pp_ty unicode = ppTyName :: Name -> Html -ppTyName = ppName (Just False) +ppTyName = ppName Prefix -------------------------------------------------------------------------------- @@ -273,7 +273,7 @@ ppDataBinderWithVars summ decl = -- | Print an application of a DocName and two lists of HsTypes (kinds, types) ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> Qualification -> Html ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (ppDocName qual . Just) (ppParendType unicode qual) + ppTypeApp n ks ts (ppDocName qual) (ppParendType unicode qual) -- | Print an application of a DocName and a list of Names @@ -281,20 +281,20 @@ ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html ppAppDocNameNames summ n ns = ppTypeApp n [] ns ppDN ppTyName where - ppDN is_infix = ppBinderFixity is_infix summ . nameOccName . getName - ppBinderFixity True = ppBinderInfix - ppBinderFixity False = ppBinder + ppDN notation = ppBinderFixity notation summ . nameOccName . getName + ppBinderFixity Infix = ppBinderInfix + ppBinderFixity _ = ppBinder -- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (Bool -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> 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 True n <+> ppT t2 + opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 -ppTypeApp n ks ts ppDN ppT = ppDN False n <+> hsep (map ppT $ ks ++ ts) +ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) ------------------------------------------------------------------------------- @@ -350,7 +350,7 @@ ppFds fds unicode qual = char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 - ppVars = hsep . map (ppDocName qual (Just False)) + ppVars = hsep . map (ppDocName qual Prefix) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification @@ -564,7 +564,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual <+> darrow unicode +++ toHtml " ") where ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName (Just False)) tvs) <+> toHtml ". " + Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " Implicit -> noHtml @@ -728,7 +728,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 (Just False) name +ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix 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 = @@ -756,7 +756,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 = ppLDocName qual (Just True) op + ppr_op = ppLDocName qual Infix 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 69174e96..69bb94c2 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 Nothing) + where fmt = parHtmlMarkup qual (ppDocName qual Raw) origDocToHtml :: Qualification -> Doc Name -> Html origDocToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual (ppName Nothing) + where fmt = parHtmlMarkup qual (ppName Raw) rdrDocToHtml :: Qualification -> Doc RdrName -> Html diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 1bd2cbc4..24577e2a 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -13,9 +13,7 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, - ppIPName, - linkId + ppModule, ppModuleRef, ppIPName, linkId, Notation(..) ) where @@ -34,6 +32,12 @@ import RdrName import FastString (unpackFS) +-- | Indicator of how to render a 'DocName' into 'Html' +data Notation = Raw -- ^ Render as-is. + | Infix -- ^ Render using infix notation. + | Prefix -- ^ Render using prefix notation. + deriving (Eq, Show) + ppOccName :: OccName -> Html ppOccName = toHtml . occNameString @@ -50,87 +54,83 @@ ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TOD -- 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 - +ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName qual notation (L _ d) = ppDocName qual notation d --- 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 = +ppDocName :: Qualification -> Notation -> DocName -> Html +ppDocName qual notation docName = case docName of Documented name mdl -> - linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual is_infix name mdl + linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual notation name mdl Undocumented name | isExternalName name || isWiredInName name -> - ppQualifyName qual is_infix name (nameModule name) - | otherwise -> ppName is_infix name + ppQualifyName qual notation name (nameModule name) + | otherwise -> ppName notation name -- | Render a name depending on the selected qualification mode -ppQualifyName :: Qualification -> Maybe Bool -> Name -> Module -> Html -ppQualifyName qual is_infix name mdl = +ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html +ppQualifyName qual notation name mdl = case qual of - NoQual -> ppName is_infix name - FullQual -> ppFullQualName is_infix mdl name + NoQual -> ppName notation name + FullQual -> ppFullQualName notation mdl name LocalQual localmdl -> if moduleString mdl == moduleString localmdl - then ppName is_infix name - else ppFullQualName is_infix mdl name + then ppName notation name + else ppFullQualName notation mdl name RelativeQual localmdl -> case List.stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x - Just [] -> ppName is_infix name + Just [] -> ppName notation 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 is_infix mdl name + Just _ -> ppFullQualName notation mdl name -- some other module, D.x -> D.x - Nothing -> ppFullQualName is_infix mdl name + Nothing -> ppFullQualName notation mdl name AliasedQual aliases localmdl -> case (moduleString mdl == moduleString localmdl, M.lookup mdl aliases) of - (False, Just alias) -> ppQualName is_infix alias name - _ -> ppName is_infix name + (False, Just alias) -> ppQualName notation alias name + _ -> ppName notation name -ppFullQualName :: Maybe Bool -> Module -> Name -> Html -ppFullQualName is_infix mdl name = wrapInfix is_infix (getOccName name) qname +ppFullQualName :: Notation -> Module -> Name -> Html +ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname where qname = toHtml $ moduleString mdl ++ '.' : getOccString name -ppQualName :: Maybe Bool -> ModuleName -> Name -> Html -ppQualName is_infix mdlName name = wrapInfix is_infix (getOccName name) qname +ppQualName :: Notation -> ModuleName -> Name -> Html +ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname where qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name -ppName :: Maybe Bool -> Name -> Html -ppName is_infix name = wrapInfix is_infix (getOccName name) $ toHtml (getOccString name) +ppName :: Notation -> Name -> Html +ppName notation name = wrapInfix notation (getOccName 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' False n +ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' False n + << ppBinder' Prefix n ppBinderInfix :: Bool -> OccName -> Html -ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' True n +ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' True n - -ppBinder' :: Bool -> OccName -> Html --- The Bool indicates if it is to be rendered in infix notation -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 + << ppBinder' Infix n + +ppBinder' :: Notation -> OccName -> Html +ppBinder' notation n = wrapInfix notation n $ ppOccName n + +wrapInfix :: Notation -> OccName -> Html -> Html +wrapInfix notation n = case notation of + Infix | is_star_kind -> id + | not is_sym -> quote + Prefix | is_star_kind -> id + | is_sym -> parens + _ -> id where is_sym = isSymOcc n is_star_kind = isTcOcc n && occNameString n == "*" |