@since includes package name (#749)

* Metadoc stores a package name

This means that '@since' annotations can be package aware.

* Get the package name the right way

This should extract the package name for `@since` annotations the
right way. I had to move `modulePackageInfo` around to do this and,
in the process, I took the liberty to update it.

Since it appears that finding the package name is something that can
fail, I added a warning for this case.

* Silence warnings

* Hide package for local 'since' annotations

As discussed, this is still the usual case (and we should avoid being
noisy for it).

Although this commit is large, it is basically only about threading a
'Maybe Package' from 'Haddock.render' all the way to
'Haddock.Backends.Xhtml.DocMarkup.renderMeta'.

* Bump binary interface version

* Add a '--since-qual' option

This controls when to qualify since annotations with the package they
come from. The default is always, but I've left an 'external' variant
where only those annotations coming from outside of the current
package are qualified.

* Make ParserSpec work

* Make Fixtures work

* Use package name even if package version is not available

The @since stuff needs only the package name passed in, so it
makes sense to not be forced to pass in a version too.

1 files changed, 29 insertions, 43 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index dc903e08..00eb50f6 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -25,7 +25,6 @@ module Haddock (
   withGhc
 ) where
 
-import Data.Version
 import Haddock.Backends.Xhtml
 import Haddock.Backends.Xhtml.Meta
 import Haddock.Backends.Xhtml.Themes (getThemes)
@@ -42,7 +41,6 @@ import Haddock.Options
 import Haddock.Utils
 
 import Control.Monad hiding (forM_)
-import Control.Applicative
 import Data.Foldable (forM_, foldl')
 import Data.Traversable (for)
 import Data.List (isPrefixOf)
@@ -151,7 +149,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
   -- or which exits with an error or help message.
   (flags, files) <- parseHaddockOpts args
   shortcutFlags flags
-  qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
+  qual <- rightOrThrowE (qualification flags)
+  sinceQual <- rightOrThrowE (sinceQualification flags)
 
   -- inject dynamic-too into flags before we proceed
   flags' <- ghc flags $ do
@@ -184,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           }
 
       -- Render the interfaces.
-      liftIO $ renderStep dflags flags qual packages ifaces
+      liftIO $ renderStep dflags flags sinceQual qual packages ifaces
 
     else do
       when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -194,7 +193,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
       packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
 
       -- Render even though there are no input files (usually contents/index).
-      liftIO $ renderStep dflags flags qual packages []
+      liftIO $ renderStep dflags flags sinceQual qual packages []
 
 -- | Create warnings about potential misuse of -optghc
 warnings :: [String] -> [String]
@@ -228,8 +227,9 @@ readPackagesAndProcessModules flags files = do
     return (packages, ifaces, homeLinks)
 
 
-renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags flags qual pkgs interfaces = do
+renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption
+           -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags sinceQual nameQual pkgs interfaces = do
   updateHTMLXRefs pkgs
   let
     ifaceFiles = map snd pkgs
@@ -238,12 +238,12 @@ renderStep dflags flags qual pkgs interfaces = do
       ((_, Just path), ifile) <- pkgs
       iface <- ifInstalledIfaces ifile
       return (instMod iface, path)
-
-  render dflags flags qual interfaces installedIfaces extSrcMap
+  render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap
 
 -- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
-render dflags flags qual ifaces installedIfaces extSrcMap = do
+render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]
+       -> [InstalledInterface] -> Map Module FilePath -> IO ()
+render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
@@ -270,6 +270,10 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
     pkgKey           = moduleUnitId pkgMod
     pkgStr           = Just (unitIdString pkgKey)
     pkgNameVer       = modulePackageInfo dflags flags pkgMod
+    pkgName          = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)
+    sincePkg         = case sinceQual of
+                         External -> pkgName
+                         Always -> Nothing
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
 
@@ -338,7 +342,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
            ppHtmlContents dflags' odir title pkgStr
                      themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
                      allVisibleIfaces True prologue pretty
-                     (makeContentsQual qual)
+                     sincePkg (makeContentsQual qual)
       return ()
     copyHtmlBits odir libDir themes withQuickjump
 
@@ -348,7 +352,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
            ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
                   prologue
                   themes opt_mathjax sourceUrls' opt_wiki_urls
-                  opt_contents_url opt_index_url unicode qual
+                  opt_contents_url opt_index_url unicode sincePkg qual
                   pretty withQuickjump
       return ()
     copyHtmlBits odir libDir themes withQuickjump
@@ -358,7 +362,12 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
   -- might want to fix that if/when these two get some work on them
   when (Flag_Hoogle `elem` flags) $ do
     case pkgNameVer of
-      Nothing -> putStrLn . unlines $
+      (Just (PackageName pkgNameFS), Just pkgVer) ->
+          let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
+                         | otherwise = unpackFS pkgNameFS
+          in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
+               visibleIfaces odir
+      _ -> putStrLn . unlines $
           [ "haddock: Unable to find a package providing module "
             ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle."
           , ""
@@ -366,14 +375,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
             ++ " using the --package-name"
           , "         and --package-version arguments."
           ]
-      Just (PackageName pkgNameFS, pkgVer) ->
-          let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
-                         | otherwise = unpackFS pkgNameFS
-          in withTiming (pure dflags') "ppHoogle" (const ()) $ do
-               _ <- {-# SCC ppHoogle #-}
-                    ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
-                      visibleIfaces odir
-               return ()
 
   when (Flag_LaTeX `elem` flags) $ do
     withTiming (pure dflags') "ppLatex" (const ()) $ do
@@ -388,26 +389,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
            ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
       return ()
 
--- | From GHC 7.10, this function has a potential to crash with a
--- nasty message such as @expectJust getPackageDetails@ because
--- package name and versions can no longer reliably be extracted in
--- all cases: if the package is not installed yet then this info is no
--- longer available. The @--package-name@ and @--package-version@
--- Haddock flags allow the user to specify this information and it is
--- returned here if present: if it is not present, the error will
--- occur. Nasty but that's how it is for now. Potential TODO.
-modulePackageInfo :: DynFlags
-                  -> [Flag] -- ^ Haddock flags are checked as they may
-                            -- contain the package name or version
-                            -- provided by the user which we
-                            -- prioritise
-                  -> Module -> Maybe (PackageName, Data.Version.Version)
-modulePackageInfo dflags flags modu =
-    cmdline <|> pkgDb
-  where
-    cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags
-    pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu)
-
 
 -------------------------------------------------------------------------------
 -- * Reading and dumping interface files
@@ -628,10 +609,15 @@ getPrologue dflags flags =
       h <- openFile filename ReadMode
       hSetEncoding h utf8
       str <- hGetContents h -- semi-closes the handle
-      return . Just $! parseParas dflags str
+      return . Just $! parseParas dflags Nothing str
     _ -> throwE "multiple -p/--prologue options"
 
 
+rightOrThrowE :: Either String b -> IO b
+rightOrThrowE (Left msg) = throwE msg
+rightOrThrowE (Right x) = pure x
+
+
 #ifdef IN_GHC_TREE
 
 getInTreeDir :: IO String