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)

5 files changed, 58 insertions, 22 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 358e5c3a..1378c173 100644
--- a/haddock-api/src/Haddock.hs
+++ b/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"
 
 
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 59ad4fdf..66083cf5 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/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)))
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 050901b6..802ea773 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -16,7 +16,6 @@ import Data.Char
 import DynFlags
 import Haddock.Parser
 import Haddock.Types
-import RdrName
 
 -- -----------------------------------------------------------------------------
 -- Parsing module headers
@@ -24,7 +23,7 @@ import RdrName
 -- 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)
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index e31ea6a8..8b7dda7c 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/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
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index a4ef5f82..e8da4120 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/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