From 91e2c21cfdaca7913dbfec17bdd7712c0c1ed732 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Wed, 19 Feb 2014 05:11:34 +0000
Subject: Use a bespoke data type to indicate fixity
This deals with what I imagine was an ancient TODO and makes it much
clearer what the argument actually does rather than having the user
chase down the comment.
---
src/Haddock/Backends/Xhtml/Decl.hs | 24 ++++-----
src/Haddock/Backends/Xhtml/DocMarkup.hs | 4 +-
src/Haddock/Backends/Xhtml/Names.hs | 92 ++++++++++++++++-----------------
3 files changed, 60 insertions(+), 60 deletions(-)
(limited to 'src/Haddock/Backends/Xhtml')
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 == "*"
--
cgit v1.2.3