Merge http://code.haskell.org/~thielema/haddock/ into ghc-7.4

5 files changed, 49 insertions, 27 deletions

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 84468610..686bd36b 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -66,7 +66,7 @@ ppHtml :: String
        -> Maybe String                 -- ^ The contents URL (--use-contents)
        -> Maybe String                 -- ^ The index URL (--use-index)
        -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)
-       -> Qualification                -- ^ How to qualify names
+       -> QualOption                   -- ^ How to qualify names
        -> Bool                         -- ^ Output pretty html (newlines and indenting)
        -> IO ()
 
@@ -83,7 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue
         themes maybe_index_url maybe_source_url maybe_wiki_url
         (map toInstalledIface visible_ifaces)
         False -- we don't want to display the packages in a single-package contents
-        prologue debug qual
+        prologue debug (makeContentsQual qual)
 
   when (isNothing maybe_index_url) $
     ppHtmlIndex odir doctitle maybe_package
@@ -461,7 +461,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
 ppHtmlModule
         :: FilePath -> String -> Themes
         -> SourceURLs -> WikiURLs
-        -> Maybe String -> Maybe String -> Bool -> Qualification
+        -> Maybe String -> Maybe String -> Bool -> QualOption
         -> Bool -> Interface -> IO ()
 ppHtmlModule odir doctitle themes
   maybe_source_url maybe_wiki_url
@@ -469,10 +469,7 @@ ppHtmlModule odir doctitle themes
   let
       mdl = ifaceMod iface
       mdl_str = moduleString mdl
-      real_qual = case qual of
-          LocalQual Nothing    -> LocalQual (Just mdl)
-          RelativeQual Nothing -> RelativeQual (Just mdl)
-          _                     -> qual
+      real_qual = makeModuleQual qual mdl
       html =
         headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
         bodyHtml doctitle (Just iface)
@@ -484,8 +481,7 @@ ppHtmlModule odir doctitle themes
 
   createDirectoryIfMissing True odir
   writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
-  ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug
-
+  ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug
 
 ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
   -> Interface -> Bool -> Qualification -> Bool -> IO ()
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 274078a6..9963fffc 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -64,14 +64,10 @@ ppQualifyName qual name mdl =
   case qual of
     NoQual   -> ppName name
     FullQual -> ppFullQualName mdl name
-    -- this is just in case, it should never happen
-    LocalQual Nothing -> ppQualifyName FullQual name mdl
-    LocalQual (Just localmdl)
+    LocalQual localmdl
       | moduleString mdl == moduleString localmdl -> ppName name
       | otherwise -> ppFullQualName mdl name
-    -- again, this never happens
-    RelativeQual Nothing -> ppQualifyName FullQual name mdl
-    RelativeQual (Just localmdl) ->
+    RelativeQual localmdl ->
       case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
         -- local, A.x -> x
         Just []      -> ppQualifyName NoQual name mdl
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 4e42fd32..537bffac 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -229,13 +229,16 @@ optLaTeXStyle :: [Flag] -> Maybe String
 optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
 
 
-qualification :: [Flag] -> Qualification
+qualification :: [Flag] -> Either String QualOption
 qualification flags =
   case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
-      "full":_     -> FullQual
-      "local":_    -> LocalQual Nothing
-      "relative":_ -> RelativeQual Nothing
-      _            -> NoQual
+      []           -> Right OptNoQual
+      ["none"]     -> Right OptNoQual
+      ["full"]     -> Right OptFullQual
+      ["local"]    -> Right OptLocalQual
+      ["relative"] -> Right OptRelativeQual
+      [arg]        -> Left $ "unknown qualification type " ++ show arg
+      _:_          -> Left "qualification option given multiple times"
 
 
 verbosity :: [Flag] -> Verbosity
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 22d2f6ae..de0cc3d9 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -374,12 +374,34 @@ data DocOption
 
 
 -- | Option controlling how to qualify names
+data QualOption
+  = OptNoQual        -- ^ Never qualify any names.
+  | OptFullQual      -- ^ Qualify all names fully.
+  | OptLocalQual     -- ^ Qualify all imported names fully.
+  | OptRelativeQual  -- ^ Like local, but strip module prefix
+                     --   from modules in the same hierarchy.
+
 data Qualification
-  = NoQual                       -- ^ Never qualify any names.
-  | FullQual                     -- ^ Qualify all names fully.
-  | LocalQual (Maybe Module)     -- ^ Qualify all imported names fully.
-  | RelativeQual (Maybe Module)  -- ^ Like local, but strip module prefix.
-                                 --   from modules in the same hierarchy.
+  = NoQual
+  | FullQual
+  | LocalQual Module
+  | RelativeQual Module
+       -- ^ @Maybe Module@ contains the current module.
+       --   This way we can distinguish imported and local identifiers.
+
+makeContentsQual :: QualOption -> Qualification
+makeContentsQual qual =
+  case qual of
+    OptNoQual -> NoQual
+    _         -> FullQual
+
+makeModuleQual :: QualOption -> Module -> Qualification
+makeModuleQual qual mdl =
+  case qual of
+    OptLocalQual    -> LocalQual mdl
+    OptRelativeQual -> RelativeQual mdl
+    OptFullQual     -> FullQual
+    OptNoQual       -> NoQual
 
 
 -----------------------------------------------------------------------------
diff --git a/src/Main.hs b/src/Main.hs
index c0b7df4b..4f0784eb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -190,6 +190,11 @@ renderStep flags pkgs interfaces = do
 render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
 render flags ifaces installedIfaces srcMap = do
 
+  opt_qualification <-
+    case qualification flags of
+      Left msg -> throwE msg
+      Right q -> return q
+
   let
     title                = fromMaybe "" (optTitle flags)
     unicode              = Flag_UseUnicode `elem` flags
@@ -199,7 +204,6 @@ render flags ifaces installedIfaces srcMap = do
     opt_index_url        = optIndexUrl       flags
     odir                 = outputDir         flags
     opt_latex_style      = optLaTeXStyle     flags
-    opt_qualification    = qualification     flags
 
     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
 
@@ -229,7 +233,8 @@ render flags ifaces installedIfaces srcMap = do
   when (Flag_GenContents `elem` flags) $ do
     ppHtmlContents odir title pkgStr
                    themes opt_index_url sourceUrls' opt_wiki_urls
-                   allVisibleIfaces True prologue pretty opt_qualification
+                   allVisibleIfaces True prologue pretty
+                   (makeContentsQual opt_qualification)
     copyHtmlBits odir libDir themes
 
   when (Flag_Html `elem` flags) $ do