adding support for local and relative name qualification

4 files changed, 46 insertions, 10 deletions

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 452fdfa0..433ea212 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -458,13 +458,17 @@ ppHtmlModule odir doctitle themes
   let
       mdl = ifaceMod iface
       mdl_str = moduleString mdl
+      real_quali = case quali of
+          LocalQuali Nothing    -> LocalQuali (Just mdl)
+          RelativeQuali Nothing -> RelativeQuali (Just mdl)
+          _                     -> quali
       html =
         headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
         bodyHtml doctitle (Just iface)
           maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url << [
             divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
-            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode quali
+            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_quali
           ]
 
   createDirectoryIfMissing True odir
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 6df32fc4..016aac14 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -24,6 +24,7 @@ import Haddock.Types
 import Haddock.Utils
 
 import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.List as List
 
 import GHC
 import Name
@@ -41,18 +42,42 @@ ppRdrName = ppOccName . rdrNameOcc
 ppLDocName :: Qualification -> Located DocName -> Html
 ppLDocName quali (L _ d) = ppDocName quali d
 
+-- | Render a name depending on the selected qualification mode
+qualifyName :: Qualification -> DocName -> Html
+qualifyName quali docName@(Documented name mdl) = case quali of
+    NoQuali   -> ppName name
+    FullQuali -> ppFullQualName mdl name
+    -- this is just in case, it should never happen
+    LocalQuali Nothing -> qualifyName FullQuali docName
+    LocalQuali (Just localmdl) ->
+        if (moduleString mdl == moduleString localmdl)
+            then ppName name
+            else ppFullQualName mdl name
+    -- again, this never happens
+    RelativeQuali Nothing -> qualifyName FullQuali docName
+    RelativeQuali (Just localmdl) ->
+        case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+            -- local, A.x -> x
+            Just []      -> qualifyName NoQuali docName
+            -- sub-module, A.B.x -> B.x
+            Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
+            -- some module with same prefix, ABC.x -> ABC.x
+            Just _       -> qualifyName FullQuali docName
+            -- some other module, D.x -> D.x
+            Nothing      -> qualifyName FullQuali docName
+
+-- this is just for exhaustiveness, but already handled by ppDocName
+qualifyName _ (Undocumented name) = ppName name
 
 ppDocName :: Qualification -> DocName -> Html
-ppDocName quali (Documented name mdl) =
-  linkIdOcc mdl (Just occName) << theName
+ppDocName quali docName@(Documented name mdl) =
+  linkIdOcc mdl (Just occName) << qualifyName quali docName
     where occName = nameOccName name
-          theName = case quali of
-              NoQuali   -> ppName name
-              FullQuali -> ppQualName mdl name
+
 ppDocName _ (Undocumented name) = ppName name
 
-ppQualName :: Module -> Name -> Html
-ppQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
+ppFullQualName :: Module -> Name -> Html
+ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
 
 ppName :: Name -> Html
 ppName name = toHtml (getOccString name)
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 6e590201..71a5fd85 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -36,6 +36,7 @@ import Distribution.Verbosity
 import Haddock.Utils
 import Haddock.Types
 import System.Console.GetOpt
+import qualified Data.Char as Char
 
 
 data Flag
@@ -123,7 +124,8 @@ options backwardsCompat =
     Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
       "page heading",
     Option ['q']  ["qual"] (ReqArg Flag_Qualification "QUALI")
-      "qualification of names, either \n'none' (default) or 'full'",
+      "qualification of names, one of \n'none' (default), 'full', 'local'\
+      \\nor 'relative'",
     Option ['d']  ["debug"]  (NoArg Flag_Debug)
       "extra debugging output",
     Option ['?']  ["help"]  (NoArg Flag_Help)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 0f868555..02e80db6 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -355,7 +355,12 @@ data DocOption
   deriving (Eq, Show)
 
 -- | Option controlling how to qualify names
-data Qualification = NoQuali | FullQuali
+data Qualification
+    = NoQuali                      -- ^ Never qualify any names
+    | FullQuali                    -- ^ Qualify all names fully
+    | LocalQuali (Maybe Module)    -- ^ Qualify all imported names fully
+    | RelativeQuali (Maybe Module) -- ^ Like local, but strip module prefix
+                                   --   from modules in the same hierarchy
 
 -----------------------------------------------------------------------------
 -- * Error handling