Support value/type namespaces on identifier links

Identifier links can be prefixed with a 'v' or 't' to indicate the value or
type namespace of the desired identifier. For example:

-- | Some link to a value: v'Data.Functor.Identity'
--
-- Some link to a type: t'Data.Functor.Identity'

The default is still the type (with a warning about the ambiguity)

doc/markup.rst

@@ -913,6 +913,16 @@ If ``M.T`` is not otherwise in scope, then Haddock will simply emit a
 link pointing to the entity ``T`` exported from module ``M`` (without
 checking to see whether either ``M`` or ``M.T`` exist).
 
+Since values and types live in different namespaces in Haskell, it is
+possible for a reference such as ``'X'`` to be ambiguous. In such a case,
+Haddock defaults to pointing to the type. The ambiguity can be overcome by explicitly specifying a namespace, by way of a ``v`` (for value) or ``t``
+(for type) immediately before the link: ::
+
+    -- | An implicit reference to  'X', the type constructor
+    --   An explicit reference to v'X', the data constructor
+    --   An explicit reference to t'X', the type constructor
+    data X = X
+
 To make life easier for documentation writers, a quoted identifier is
 only interpreted as such if the quotes surround a lexically valid
 Haskell identifier. This means, for example, that it normally isn't

haddock-api/src/Haddock.hs

@@ -42,6 +42,7 @@ import Haddock.Utils
 import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
 
 import Control.Monad hiding (forM_)
+import Data.Bifunctor (second)
 import Data.Foldable (forM_, foldl')
 import Data.Traversable (for)
 import Data.List (isPrefixOf)
@@ -662,7 +663,7 @@ getPrologue dflags flags =
       h <- openFile filename ReadMode
       hSetEncoding h utf8
       str <- hGetContents h -- semi-closes the handle
-      return . Just $! parseParas dflags Nothing str
+      return . Just $! second rdrName $ parseParas dflags Nothing str
     _ -> throwE "multiple -p/--prologue options"
 
 

haddock-api/src/Haddock/Interface/LexParseRn.hs

@@ -34,8 +34,8 @@ import Haddock.Types
 import Name
 import Outputable ( showPpr, showSDoc )
 import RdrName
+import RdrHsSyn (setRdrNameSpace)
 import EnumSet
-import RnEnv (dataTcOccs)
 
 processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
                   -> ErrMsgM (Maybe (MDoc Name))
@@ -89,24 +89,37 @@ processModuleHeader dflags pkgName gre safety mayStr = do
 -- fallbacks in case we can't locate the identifiers.
 --
 -- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
+rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name)
 rename dflags gre = rn
   where
     rn d = case d of
       DocAppend a b -> DocAppend <$> rn a <*> rn b
       DocParagraph doc -> DocParagraph <$> rn doc
-      DocIdentifier x -> do
+      DocIdentifier (NsRdrName ns x) -> do
+        let occ = rdrNameOcc x
+            isValueName = isDataOcc occ || isVarOcc occ
+
+        let valueNsChoices | isValueName = [x]
+                           | otherwise   = [] -- is this ever possible?
+            typeNsChoices  | isValueName = [setRdrNameSpace x tcName]
+                           | otherwise   = [x]
+
         -- Generate the choices for the possible kind of thing this
-        -- is.
-        let choices = dataTcOccs x
+        -- is. We narrow down the possibilities with the namespace (if
+        -- there is one).
+        let choices = case ns of
+                        Value -> valueNsChoices
+                        Type  -> typeNsChoices
+                        None  -> valueNsChoices ++ typeNsChoices
 
         -- Lookup any GlobalRdrElts that match the choices.
         case concatMap (\c -> lookupGRE_RdrName c gre) choices of
           -- We found no names in the env so we start guessing.
           [] ->
             case choices of
-              -- This shouldn't happen as 'dataTcOccs' always returns at least its input.
-              [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
+              -- The only way this can happen is if a value namespace was
+              -- specified on something that cannot be a value.
+              [] -> invalidValue dflags x
 
               -- There was nothing in the environment so we need to
               -- pick some default from what's available to us. We
@@ -116,7 +129,7 @@ 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 a
+              a:_ -> outOfScope dflags ns a
 
           -- There is only one name in the environment that matches so
           -- use it.
@@ -155,17 +168,23 @@ 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 -> RdrName -> ErrMsgM (Doc a)
-outOfScope dflags x =
+outOfScope :: DynFlags -> Namespace -> 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
   where
+    prefix = case ns of
+               Value -> "the value "
+               Type -> "the type "
+               None -> ""
+
     warnAndMonospace a = do
-      tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++
-            "    If you qualify the identifier, haddock can try to link it anyway."]
+      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))
 
@@ -184,7 +203,7 @@ ambiguous dflags x gres = do
       msg = "Warning: " ++ x_str ++ " 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 hiding some imports.\n" ++
+            "    by specifying the type/value namespace explicitly.\n" ++
             "    Defaulting to " ++ x_str ++ " 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
@@ -198,3 +217,13 @@ ambiguous dflags x gres = do
     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 dflags x = do
+  tell ["Warning: '" ++ showPpr 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)))

haddock-api/src/Haddock/Interface/ParseModuleHeader.hs

@@ -16,15 +16,14 @@ import Data.Char
 import DynFlags
 import Haddock.Parser
 import Haddock.Types
-import RdrName
 
 -- -----------------------------------------------------------------------------
 -- Parsing module headers
 
 -- NB.  The headers must be given in the order Module, Description,
 -- Copyright, License, Maintainer, Stability, Portability, except that
 -- any or all may be omitted.
-parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
 parseModuleHeader dflags pkgName str0 =
    let
       getKey :: String -> String -> (Maybe String,String)

haddock-api/src/Haddock/Parser.hs

@@ -15,26 +15,27 @@ module Haddock.Parser ( parseParas
 
 import qualified Documentation.Haddock.Parser as P
 import Documentation.Haddock.Types
+import Haddock.Types (NsRdrName(..))
 
 import DynFlags     ( DynFlags )
 import FastString   ( fsLit )
 import Lexer        ( mkPState, unP, ParseResult(POk) )
 import Parser       ( parseIdentifier )
 import RdrName      ( RdrName )
-import SrcLoc       ( mkRealSrcLoc, unLoc )
+import SrcLoc       ( mkRealSrcLoc, GenLocated(..) )
 import StringBuffer ( stringToStringBuffer )
 
-parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName
+parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName
 parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
 
-parseString :: DynFlags -> String -> DocH mod RdrName
+parseString :: DynFlags -> String -> DocH mod NsRdrName
 parseString d = P.overIdentifier (parseIdent d) . P.parseString
 
-parseIdent :: DynFlags -> String -> Maybe RdrName
-parseIdent dflags str0 =
+parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName
+parseIdent dflags ns str0 =
   let buffer = stringToStringBuffer str0
       realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
       pstate = mkPState dflags buffer realSrcLc
   in case unP parseIdentifier pstate of
-    POk _ name -> Just (unLoc name)
+    POk _ (L _ name) -> Just (NsRdrName ns name)
     _ -> Nothing

haddock-api/src/Haddock/Types.hs

@@ -284,6 +284,12 @@ noDocForDecl = (Documentation Nothing Nothing, mempty)
 -- | Type of environment used to cross-reference identifiers in the syntax.
 type LinkEnv = Map Name Module
 
+-- | An 'RdrName' tagged with some type/value namespace information.
+data NsRdrName = NsRdrName
+  { namespace :: !Namespace
+  , rdrName :: !RdrName
+  }
+
 -- | Extends 'Name' with cross-reference information.
 data DocName
   = Documented Name Module

haddock-library/src/Documentation/Haddock/Parser.hs

@@ -28,6 +28,7 @@ import           Control.Applicative
 import           Control.Arrow (first)
 import           Control.Monad
 import           Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace)
+import           Data.Foldable (asum)
 import           Data.List (intercalate, unfoldr, elemIndex)
 import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Monoid
@@ -75,24 +76,24 @@ isSymbolChar c = not (isPuncChar c) && case generalCategory c of
 #endif
 
 -- | Identifier string surrounded with opening and closing quotes/backticks.
-type Identifier = (Char, String, Char)
+data Identifier = Identifier !Namespace !Char String !Char
 
 -- | Drops the quotes/backticks around all identifiers, as if they
 -- were valid but still 'String's.
 toRegular :: DocH mod Identifier -> DocH mod String
-toRegular = fmap (\(_, x, _) -> x)
+toRegular = fmap (\(Identifier _ _ x _) -> x)
 
 -- | Maps over 'DocIdentifier's over 'String' with potentially failing
 -- conversion using user-supplied function. If the conversion fails,
 -- the identifier is deemed to not be valid and is treated as a
 -- regular string.
-overIdentifier :: (String -> Maybe a)
+overIdentifier :: (Namespace -> String -> Maybe a)
                -> DocH mod Identifier
                -> DocH mod a
 overIdentifier f d = g d
   where
-    g (DocIdentifier (o, x, e)) = case f x of
-      Nothing -> DocString $ o : x ++ [e]
+    g (DocIdentifier (Identifier ns o x e)) = case f ns x of
+      Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e]
       Just x' -> DocIdentifier x'
     g DocEmpty = DocEmpty
     g (DocAppend x x') = DocAppend (g x) (g x')
@@ -314,7 +315,8 @@ markdownImage :: Parser (DocH mod Identifier)
 markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser)
   where
     fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l)
-    stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r])
+    stringMarkup = plainMarkup (const "") renderIdent
+    renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r]
 
 -- | Paragraph parser, called by 'parseParas'.
 paragraph :: Parser (DocH mod Identifier)
@@ -857,9 +859,13 @@ parseValid = p some
 -- 'String' from the string it deems valid.
 identifier :: Parser (DocH mod Identifier)
 identifier = do
+  ns <- asum [ Value <$ Parsec.char 'v'
+             , Type <$ Parsec.char 't'
+             , pure None
+             ]
   o <- idDelim
   vid <- parseValid
   e <- idDelim
-  return $ DocIdentifier (o, vid, e)
+  return $ DocIdentifier (Identifier ns o vid e)
   where
-    idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`')
+    idDelim = Parsec.oneOf "'`"

haddock-library/src/Documentation/Haddock/Types.hs

@@ -203,6 +203,16 @@ instance Bitraversable DocH where
   bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body
 #endif
 
+-- | The namespace qualification for an identifier.
+data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show)
+
+-- | Render the a namespace into the same format it was initially parsed.
+renderNs :: Namespace -> String
+renderNs Value = "v"
+renderNs Type = "t"
+renderNs None = ""
+
+
 -- | 'DocMarkupH' is a set of instructions for marking up documentation.
 -- In fact, it's really just a mapping from 'Doc' to some other
 -- type [a], where [a] is usually the type of the output (HTML, say).

haddock-library/test/Documentation/Haddock/ParserSpec.hs

@@ -132,6 +132,12 @@ spec = do
       it "can parse an identifier that starts with an underscore" $ do
         "'_x'" `shouldParseTo` DocIdentifier "_x"
 
+      it "can parse value-namespaced identifiers" $ do
+        "v'foo'" `shouldParseTo` DocIdentifier "foo"
+
+      it "can parse type-namespaced identifiers" $ do
+        "t'foo'" `shouldParseTo` DocIdentifier "foo"
+
     context "when parsing operators" $ do
       it "can parse an operator enclosed within single quotes" $ do
         "'.='" `shouldParseTo` DocIdentifier ".="

html-test/Main.hs

@@ -45,7 +45,7 @@ stripIfRequired mdl =
 
 -- | List of modules in which we don't 'stripLinks'
 preserveLinksModules :: [String]
-preserveLinksModules = ["Bug253"]
+preserveLinksModules = ["Bug253.html", "NamespacedIdentifiers.html"]
 
 ingoredTests :: [FilePath]
 ingoredTests =

html-test/ref/Bug253.html

@@ -4,9 +4,9 @@
      /><meta name="viewport" content="width=device-width, initial-scale=1"
      /><title
     >Bug253</title
-    ><link href="#" rel="stylesheet" type="text/css" title="NewOcean"
-     /><link rel="stylesheet" type="text/css" href="#"
-     /><link rel="stylesheet" type="text/css" href="#"
+    ><link href="new-ocean.css" rel="stylesheet" type="text/css" title="NewOcean"
+     /><link rel="stylesheet" type="text/css" href="quick-jump.css"
+     /><link rel="stylesheet" type="text/css" href="https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700"
      /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
     ></script
     ><script type="text/x-mathjax-config"
@@ -20,11 +20,11 @@
       ></span
       ><ul class="links" id="page-menu"
       ><li
-	><a href="#"
+	><a href="index.html"
 	  >Contents</a
 	  ></li
 	><li
-	><a href="#"
+	><a href="doc-index.html"
 	  >Index</a
 	  ></li
 	></ul
@@ -64,7 +64,7 @@
 	  >Synopsis</summary
 	  ><ul class="details-toggle" data-details-id="syn"
 	  ><li class="src short"
-	    ><a href="#"
+	    ><a href="#v:foo"
 	      >foo</a
 	      > :: ()</li
 	    ></ul
@@ -77,15 +77,15 @@
 	><p class="src"
 	  ><a id="v:foo" class="def"
 	    >foo</a
-	    > :: () <a href="#" class="selflink"
+	    > :: () <a href="#v:foo" class="selflink"
 	    >#</a
 	    ></p
 	  ><div class="doc"
 	  ><p
 	    >This link should generate <code
 	      >#v</code
 	      > anchor: <code
-	      ><a href="#" title="DoesNotExist"
+	      ><a href="DoesNotExist.html#v:fakeFakeFake" title="DoesNotExist"
 		>fakeFakeFake</a
 		></code
 	      ></p