Better identifier parsing

  * '(<|>)' and '`elem`' now get parsed and rendered properly as links
  * 'DbModule'/'DbUnitId' now properly get split apart into two links
  * tuple names now get parsed properly
  * some more small niceties...

The identifier parsing code is more precise and more efficient (although to be
fair: it is also longer and in its own module). On the rendering side, we need
to pipe through information about backticks/parens/neither all the way through
from renaming to the backends.

In terms of impact: a total of 35 modules in the entirety of the bootlib + ghc
lib docs change. The only "regression" is things like '\0'. These should be
changed to @\\0@ (the path by which this previously worked seems accidental).

10 files changed, 141 insertions, 65 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9e3186e5..f581c01a 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -334,7 +334,7 @@ markupTag dflags = Markup {
   markupString               = str,
   markupAppend               = (++),
   markupIdentifier           = box (TagInline "a") . str . out dflags,
-  markupIdentifierUnchecked  = box (TagInline "a") . str . out dflags . snd,
+  markupIdentifierUnchecked  = box (TagInline "a") . str . showWrapped (out dflags . snd),
   markupModule               = box (TagInline "a") . str,
   markupWarning              = box (TagInline "i"),
   markupEmphasis             = box (TagInline "i"),
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d0752506..85769b13 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1106,8 +1106,8 @@ ppSymName name
   | otherwise = ppName name
 
 
-ppVerbOccName :: OccName -> LaTeX
-ppVerbOccName = text . latexFilter . occNameString
+ppVerbOccName :: Wrap OccName -> LaTeX
+ppVerbOccName = text . latexFilter . showWrapped occNameString
 
 ppIPName :: HsIPName -> LaTeX
 ppIPName = text . ('?':) . unpackFS . hsIPNameFS
@@ -1115,13 +1115,12 @@ ppIPName = text . ('?':) . unpackFS . hsIPNameFS
 ppOccName :: OccName -> LaTeX
 ppOccName = text . occNameString
 
+ppVerbDocName :: Wrap DocName -> LaTeX
+ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName)
 
-ppVerbDocName :: DocName -> LaTeX
-ppVerbDocName = ppVerbOccName . nameOccName . getName
 
-
-ppVerbRdrName :: RdrName -> LaTeX
-ppVerbRdrName = ppVerbOccName . rdrNameOcc
+ppVerbRdrName :: Wrap RdrName -> LaTeX
+ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc)
 
 
 ppDocName :: DocName -> LaTeX
@@ -1182,7 +1181,7 @@ parLatexMarkup ppId = Markup {
   markupString               = \s v -> text (fixString v s),
   markupAppend               = \l r v -> l v <> r v,
   markupIdentifier           = markupId ppId,
-  markupIdentifierUnchecked  = markupId (ppVerbOccName . snd),
+  markupIdentifierUnchecked  = markupId (ppVerbOccName . fmap snd),
   markupModule               = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
   markupWarning              = \p v -> emph (p v),
   markupEmphasis             = \p v -> emph (p v),
@@ -1239,11 +1238,11 @@ parLatexMarkup ppId = Markup {
       where theid = ppId_ id
 
 
-latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
+latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX)
 latexMarkup = parLatexMarkup ppVerbDocName
 
 
-rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
+rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX)
 rdrLatexMarkup = parLatexMarkup ppVerbRdrName
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 09aabc0c..1901cf05 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -171,12 +171,12 @@ flatten x = [x]
 -- extract/append the underlying 'Doc' and convert it to 'Html'. For
 -- 'CollapsingHeader', we attach extra info to the generated 'Html'
 -- that allows us to expand/collapse the content.
-hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html
+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html
 hackMarkup fmt' currPkg h' =
   let (html, ms) = hackMarkup' fmt' h'
   in html +++ renderMeta fmt' currPkg (metaConcat ms)
   where
-    hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id
+    hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id
                 -> (Html, [Meta])
     hackMarkup' fmt h = case h of
       UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
@@ -206,7 +206,7 @@ renderMeta _ _ _ = noHtml
 -- | Goes through 'hackMarkup' to generate the 'Html' rather than
 -- skipping straight to 'markup': this allows us to employ XHtml
 -- specific hacks to the tree first.
-markupHacked :: DocMarkup id Html
+markupHacked :: DocMarkup (Wrap id) Html
              -> Maybe Package      -- this package
              -> Maybe String
              -> MDoc id
@@ -220,7 +220,7 @@ docToHtml :: Maybe String  -- ^ Name of the thing this doc is for. See
           -> Maybe Package -- ^ Current package
           -> Qualification -> MDoc DocName -> Html
 docToHtml n pkg qual = markupHacked fmt pkg n . cleanup
-  where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
+  where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw)
 
 -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
 -- in links. This is used to generate the Contents box elements.
@@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String  -- ^ See 'toHack'
                    -> Maybe Package -- ^ Current package
                    -> Qualification -> MDoc DocName -> Html
 docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
-  where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
+  where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw)
 
 origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
 origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
-  where fmt = parHtmlMarkup qual True (const $ ppName Raw)
+  where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw))
 
 
 rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
 rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
-  where fmt = parHtmlMarkup qual True (const ppRdrName)
+  where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap))
 
 
 docElement :: (Html -> Html) -> Html -> Html
@@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists)
     unParagraph (DocParagraph d) = d
     unParagraph doc              = doc
 
-    fmtUnParagraphLists :: DocMarkup a (Doc a)
+    fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
     fmtUnParagraphLists = idMarkup {
       markupUnorderedList = DocUnorderedList . map unParagraph,
       markupOrderedList   = DocOrderedList   . map unParagraph
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 574045e0..6a047747 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -13,7 +13,8 @@
 module Haddock.Backends.Xhtml.Names (
   ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
   ppBinder, ppBinderInfix, ppBinder',
-  ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
+  ppModule, ppModuleRef, ppIPName, linkId, Notation(..),
+  ppWrappedDocName, ppWrappedName,
 ) where
 
 
@@ -24,7 +25,7 @@ import Haddock.Utils
 
 import Text.XHtml hiding ( name, p, quote )
 import qualified Data.Map as M
-import qualified Data.List as List
+import Data.List ( stripPrefix )
 
 import GHC hiding (LexicalFixity(..))
 import Name
@@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html
 ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
 
 
-ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
-ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
-
+ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html
+ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml
+  where
+    (mdl, occ) = unwrap x
+    occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName
 
 -- The Bool indicates if it is to be rendered in infix notation
 ppLDocName :: Qualification -> Notation -> Located DocName -> Html
@@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName =
           ppQualifyName qual notation name (nameModule name)
       | otherwise -> ppName notation name
 
+
+ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html
+ppWrappedDocName qual notation insertAnchors docName = case docName of
+  Unadorned n -> ppDocName qual notation insertAnchors n
+  Parenthesized n -> ppDocName qual Prefix insertAnchors n
+  Backticked n -> ppDocName qual Infix insertAnchors n
+
+ppWrappedName :: Notation -> Wrap Name -> Html
+ppWrappedName notation docName = case docName of
+  Unadorned n -> ppName notation n
+  Parenthesized n -> ppName Prefix n
+  Backticked n -> ppName Infix n
+
 -- | Render a name depending on the selected qualification mode
 ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
 ppQualifyName qual notation name mdl =
@@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl =
         then ppName notation name
         else ppFullQualName notation mdl name
     RelativeQual localmdl ->
-      case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+      case stripPrefix (moduleString localmdl) (moduleString mdl) of
         -- local, A.x -> x
         Just []      -> ppName notation name
         -- sub-module, A.B.x -> B.x
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 636d3e19..a9834fa0 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} =
              ]
 
 jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+jsonDoc doc = jsonString (show (bimap showModName showName doc))
+  where
+    showModName = showWrapped (moduleNameString . fst)
+    showName = showWrapped nameStableString
 
 jsonModule :: Module -> JsonDoc
 jsonModule = JSString . moduleStableString
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 66083cf5..faf23728 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -22,6 +22,7 @@ module Haddock.Interface.LexParseRn
 import Avail
 import Control.Arrow
 import Control.Monad
+import Data.Functor (($>))
 import Data.List
 import Data.Ord
 import Documentation.Haddock.Doc (metaDocConcat)
@@ -95,8 +96,9 @@ rename dflags gre = rn
     rn d = case d of
       DocAppend a b -> DocAppend <$> rn a <*> rn b
       DocParagraph doc -> DocParagraph <$> rn doc
-      DocIdentifier (NsRdrName ns x) -> do
-        let occ = rdrNameOcc x
+      DocIdentifier i -> do
+        let NsRdrName ns x = unwrap i
+            occ = rdrNameOcc x
             isValueName = isDataOcc occ || isVarOcc occ
 
         let valueNsChoices | isValueName = [x]
@@ -119,7 +121,7 @@ rename dflags gre = rn
             case choices of
               -- The only way this can happen is if a value namespace was
               -- specified on something that cannot be a value.
-              [] -> invalidValue dflags x
+              [] -> invalidValue dflags i
 
               -- There was nothing in the environment so we need to
               -- pick some default from what's available to us. We
@@ -129,14 +131,14 @@ rename dflags gre = rn
               -- type constructor names (such as in #253). So now we
               -- only get type constructor links if they are actually
               -- in scope.
-              a:_ -> outOfScope dflags ns a
+              a:_ -> outOfScope dflags ns (i $> a)
 
           -- There is only one name in the environment that matches so
           -- use it.
-          [a] -> pure (DocIdentifier (gre_name a))
+          [a] -> pure (DocIdentifier (i $> gre_name a))
 
           -- There are multiple names available.
-          gres -> ambiguous dflags x gres
+          gres -> ambiguous dflags i gres
 
       DocWarning doc -> DocWarning <$> rn doc
       DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -168,13 +170,13 @@ rename dflags gre = rn
 -- users shouldn't rely on this doing the right thing. See tickets
 -- #253 and #375 on the confusion this causes depending on which
 -- default we pick in 'rename'.
-outOfScope :: DynFlags -> Namespace -> RdrName -> ErrMsgM (Doc a)
+outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a)
 outOfScope dflags ns x =
-  case x of
-    Unqual occ -> warnAndMonospace occ
-    Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))
-    Orig _ occ -> warnAndMonospace occ
-    Exact name -> warnAndMonospace name  -- Shouldn't happen since x is out of scope
+  case unwrap x of
+    Unqual occ -> warnAndMonospace (x $> occ)
+    Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
+    Orig _ occ -> warnAndMonospace (x $> occ)
+    Exact name -> warnAndMonospace (x $> name)  -- Shouldn't happen since x is out of scope
   where
     prefix = case ns of
                Value -> "the value "
@@ -182,11 +184,11 @@ outOfScope dflags ns x =
                None -> ""
 
     warnAndMonospace a = do
-      tell ["Warning: " ++ prefix ++ "'" ++ showPpr dflags a ++ "' is out of scope.\n" ++
-            "    If you qualify the identifier, haddock can try to link it\n" ++
-            "    it anyway."]
-      pure (monospaced a)
-    monospaced a = DocMonospaced (DocString (showPpr dflags a))
+      let a' = showWrapped (showPpr dflags) a
+      tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
+            "    If you qualify the identifier, haddock can try to link it anyway."]
+      pure (monospaced a')
+    monospaced = DocMonospaced . DocString
 
 -- | Handle ambiguous identifiers.
 --
@@ -194,36 +196,42 @@ outOfScope dflags ns x =
 --
 -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
 ambiguous :: DynFlags
-          -> RdrName
+          -> Wrap NsRdrName
           -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
           -> ErrMsgM (Doc Name)
 ambiguous dflags x gres = do
   let noChildren = map availName (gresToAvailInfo gres)
       dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
-      msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
+      msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
             concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
             "    You may be able to disambiguate the identifier by qualifying it or\n" ++
             "    by specifying the type/value namespace explicitly.\n" ++
-            "    Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+            "    Defaulting to the one defined " ++ defnLoc dflt
   -- TODO: Once we have a syntax for namespace qualification (#667) we may also
   -- want to emit a warning when an identifier is a data constructor for a type
   -- of the same name, but not the only constructor.
   -- For example, for @data D = C | D@, someone may want to reference the @D@
   -- constructor.
   when (length noChildren > 1) $ tell [msg]
-  pure (DocIdentifier dflt)
+  pure (DocIdentifier (x $> dflt))
   where
     isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
     isLocalName _ = False
-    x_str = '\'' : showPpr dflags x ++ "'"
     defnLoc = showSDoc dflags . pprNameDefnLoc
 
 -- | Handle value-namespaced names that cannot be for values.
 --
 -- Emits a warning that the value-namespace is invalid on a non-value identifier.
-invalidValue :: DynFlags -> RdrName -> ErrMsgM (Doc a)
+invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a)
 invalidValue dflags x = do
-  tell ["Warning: '" ++ showPpr dflags x ++ "' cannot be value, yet it is\n" ++
+  tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++
             "    namespaced as such. Did you mean to specify a type namespace\n" ++
             "    instead?"]
-  pure (DocMonospaced (DocString (showPpr dflags x)))
+  pure (DocMonospaced (DocString (showNsRdrName dflags x)))
+
+-- | Printable representation of a wrapped and namespaced name
+showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
+showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
+  where
+    ident = showWrapped (showPpr dflags . rdrName)
+    prefix = renderNs . namespace . unwrap
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 57e6d699..88238f04 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -173,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
 renameLDocHsSyn = return
 
 
-renameDoc :: Traversable t => t Name -> RnM (t DocName)
-renameDoc = traverse rename
+renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
+renameDoc = traverse (traverse rename)
 
 renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
 renameFnArgsDoc = mapM renameDoc
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index e1d8dbe1..7645b1bb 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
 --
 binaryInterfaceVersion :: Word16
 #if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
-binaryInterfaceVersion = 34
+binaryInterfaceVersion = 35
 
 binaryInterfaceVersionCompatibility :: [Word16]
 binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -701,3 +701,28 @@ instance Binary DocName where
         name <- get bh
         return (Undocumented name)
       _ -> error "get DocName: Bad h"
+
+instance Binary n => Binary (Wrap n) where
+  put_ bh (Unadorned n) = do
+    putByte bh 0
+    put_ bh n
+  put_ bh (Parenthesized n) = do
+    putByte bh 1
+    put_ bh n
+  put_ bh (Backticked n) = do
+    putByte bh 2
+    put_ bh n
+
+  get bh = do
+    h <- getByte bh
+    case h of
+      0 -> do
+        name <- get bh
+        return (Unadorned name)
+      1 -> do
+        name <- get bh
+        return (Parenthesized name)
+      2 -> do
+        name <- get bh
+        return (Backticked name)
+      _ -> error "get Wrap: Bad h"
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index 8b7dda7c..6d5dc103 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -15,27 +15,32 @@ module Haddock.Parser ( parseParas
 
 import qualified Documentation.Haddock.Parser as P
 import Documentation.Haddock.Types
-import Haddock.Types (NsRdrName(..))
+import Haddock.Types
 
 import DynFlags     ( DynFlags )
 import FastString   ( fsLit )
 import Lexer        ( mkPState, unP, ParseResult(POk) )
 import Parser       ( parseIdentifier )
-import RdrName      ( RdrName )
 import SrcLoc       ( mkRealSrcLoc, GenLocated(..) )
 import StringBuffer ( stringToStringBuffer )
 
-parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName
+
+parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
 parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
 
-parseString :: DynFlags -> String -> DocH mod NsRdrName
+parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
 parseString d = P.overIdentifier (parseIdent d) . P.parseString
 
-parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName
+parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
 parseIdent dflags ns str0 =
-  let buffer = stringToStringBuffer str0
+  let buffer = stringToStringBuffer str1
       realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
       pstate = mkPState dflags buffer realSrcLc
+      (wrap,str1) = case str0 of
+                      '(' : s@(c : _) | c /= ',', c /= ')'  -- rule out tuple names
+                                      -> (Parenthesized, init s)
+                      '`' : s@(_ : _) -> (Backticked,    init s)
+                      _               -> (Unadorned,     str0)
   in case unP parseIdentifier pstate of
-    POk _ (L _ name) -> Just (NsRdrName ns name)
+    POk _ (L _ name) -> Just (wrap (NsRdrName ns name))
     _ -> Nothing
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e8da4120..cd4ac1a1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -42,7 +42,7 @@ import GHC
 import DynFlags (Language)
 import qualified GHC.LanguageExtensions as LangExt
 import OccName
-import Outputable
+import Outputable hiding ((<>))
 
 -----------------------------------------------------------------------------
 -- * Convenient synonyms
@@ -334,6 +334,26 @@ instance SetName DocName where
     setName name' (Documented _ mdl) = Documented name' mdl
     setName name' (Undocumented _) = Undocumented name'
 
+-- | Adds extra "wrapper" information to a name.
+--
+-- This is to work around the fact that most name types in GHC ('Name', 'RdrName',
+-- 'OccName', ...) don't include backticks or parens.
+data Wrap n
+  = Unadorned { unwrap :: n  }     -- ^ don't do anything to the name
+  | Parenthesized { unwrap :: n }  -- ^ add parentheses around the name
+  | Backticked { unwrap :: n }     -- ^ add backticks around the name
+  deriving (Show, Functor, Foldable, Traversable)
+
+-- | Useful for debugging
+instance Outputable n => Outputable (Wrap n) where
+  ppr (Unadorned n)     = ppr n
+  ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ]
+  ppr (Backticked n)    = hcat [ char '`', ppr n, char '`' ]
+
+showWrapped :: (a -> String) -> Wrap a -> String
+showWrapped f (Unadorned n) = f n
+showWrapped f (Parenthesized n) = "(" ++ f n ++ ")"
+showWrapped f (Backticked n) = "`" ++ f n ++ "`"
 
 
 -----------------------------------------------------------------------------
@@ -429,10 +449,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where
 
 type LDoc id = Located (Doc id)
 
-type Doc id = DocH (ModuleName, OccName) id
-type MDoc id = MetaDoc (ModuleName, OccName) id
+type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id)
+type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id)
 
-type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
+type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a
 
 instance (NFData a, NFData mod)
          => NFData (DocH mod a) where