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 "+"

4 files changed, 66 insertions, 56 deletions

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)