'abbreviate' qualification style - basic support

Currently we ignore the package a module is imported from.
This means that a module import would shadow another one
with the same module name from a different package.

5 files changed, 67 insertions, 28 deletions

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 686bd36b..fc94e7d6 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -468,8 +468,9 @@ ppHtmlModule odir doctitle themes
   maybe_contents_url maybe_index_url unicode qual debug iface = do
   let
       mdl = ifaceMod iface
+      abbrevs = ifaceModuleAbbrevs iface
       mdl_str = moduleString mdl
-      real_qual = makeModuleQual qual mdl
+      real_qual = makeModuleQual qual abbrevs mdl
       html =
         headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
         bodyHtml doctitle (Just iface)
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 9963fffc..88ba14dc 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.Map as M
 import qualified Data.List as List
 
 import GHC
@@ -64,24 +65,33 @@ ppQualifyName qual name mdl =
   case qual of
     NoQual   -> ppName name
     FullQual -> ppFullQualName mdl name
-    LocalQual localmdl
-      | moduleString mdl == moduleString localmdl -> ppName name
-      | otherwise -> ppFullQualName mdl name
+    LocalQual localmdl ->
+      if moduleString mdl == moduleString localmdl
+        then ppName name
+        else ppFullQualName mdl name
     RelativeQual localmdl ->
       case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
         -- local, A.x -> x
-        Just []      -> ppQualifyName NoQual name mdl
+        Just []      -> ppName name
         -- sub-module, A.B.x -> B.x
         Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
         -- some module with same prefix, ABC.x -> ABC.x
-        Just _       -> ppQualifyName FullQual name mdl
+        Just _       -> ppFullQualName mdl name
         -- some other module, D.x -> D.x
-        Nothing      -> ppQualifyName FullQual name mdl
+        Nothing      -> ppFullQualName mdl name
+    AbbreviateQual abbrevs localmdl ->
+      case (moduleString mdl == moduleString localmdl,
+            M.lookup (moduleName mdl) abbrevs) of
+        (False, Just abbrev) -> ppQualName abbrev name
+        _ -> ppName name
 
 
 ppFullQualName :: Module -> Name -> Html
 ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
 
+ppQualName :: ModuleName -> Name -> Html
+ppQualName mdlName name =
+  toHtml $ moduleNameString mdlName ++ '.' : getOccString name
 
 ppName :: Name -> Html
 ppName name = toHtml (getOccString name)
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 94575209..9f183432 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -30,6 +30,7 @@ import Control.Applicative
 import Control.Monad
 import qualified Data.Traversable as T
 
+import qualified SrcLoc
 import GHC hiding (flags)
 import HscTypes
 import Name
@@ -106,6 +107,18 @@ createInterface tm flags modMap instIfaceMap = do
         | OptPrune `elem` opts = prunedExportItems0
         | otherwise = exportItems
 
+  let abbrevs =
+        case tm_renamed_source tm of
+          Nothing -> M.empty
+          Just (_,impDecls,_,_) ->
+            M.fromList $
+            mapMaybe (\(SrcLoc.L _ impDecl) -> do
+              abbrev <- ideclAs impDecl
+              return
+                (case ideclName impDecl of SrcLoc.L _ name -> name,
+                 abbrev))
+              impDecls
+
   return Interface {
     ifaceMod             = mdl,
     ifaceOrigFilename    = msHsFilePath ms,
@@ -123,6 +136,7 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceVisibleExports  = visibleNames,
     ifaceDeclMap         = declMap,
     ifaceSubMap          = subMap,
+    ifaceModuleAbbrevs   = abbrevs,
     ifaceInstances       = instances,
     ifaceHaddockCoverage = coverage
   }
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 537bffac..792c0be3 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -126,7 +126,7 @@ options backwardsCompat =
     Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
       "page heading",
     Option ['q']  ["qual"] (ReqArg Flag_Qualification "QUAL")
-      "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'",
+      "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'abbreviate'",
     Option ['?']  ["help"]  (NoArg Flag_Help)
       "display this help and exit",
     Option ['V']  ["version"]  (NoArg Flag_Version)
@@ -232,13 +232,14 @@ optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
 qualification :: [Flag] -> Either String QualOption
 qualification flags =
   case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
-      []           -> 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"
+      []             -> Right OptNoQual
+      ["none"]       -> Right OptNoQual
+      ["full"]       -> Right OptFullQual
+      ["local"]      -> Right OptLocalQual
+      ["relative"]   -> Right OptRelativeQual
+      ["abbreviate"] -> Right OptAbbreviateQual
+      [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 de0cc3d9..2195faf5 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -103,12 +103,15 @@ data Interface = Interface
     -- module.
   , ifaceVisibleExports  :: ![Name]
 
+    -- | Abbreviations of module imports as in @import A.B.C as C@.
+  , ifaceModuleAbbrevs   :: AbbreviationMap
+
     -- | Instances exported by the module.
   , ifaceInstances       :: ![Instance]
 
     -- | The number of haddockable and haddocked items in the module, as a
     -- tuple. Haddockable items are the exports and the module itself.
-  , ifaceHaddockCoverage  :: (Int,Int)
+  , ifaceHaddockCoverage :: (Int,Int)
   }
 
 
@@ -375,18 +378,27 @@ 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.
+  = 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.
+  | OptAbbreviateQual -- ^ Uses abbreviations of module names
+                      --   as suggested by module import renamings.
+                      --   However, we are unfortunately not able
+                      --   to maintain the original qualifications.
+                      --   Image a re-export of a whole module,
+                      --   how could the re-exported identifiers be qualified?
+
+type AbbreviationMap = Map ModuleName ModuleName
 
 data Qualification
   = NoQual
   | FullQual
   | LocalQual Module
   | RelativeQual Module
-       -- ^ @Maybe Module@ contains the current module.
+  | AbbreviateQual AbbreviationMap Module
+       -- ^ @Module@ contains the current module.
        --   This way we can distinguish imported and local identifiers.
 
 makeContentsQual :: QualOption -> Qualification
@@ -395,13 +407,14 @@ makeContentsQual qual =
     OptNoQual -> NoQual
     _         -> FullQual
 
-makeModuleQual :: QualOption -> Module -> Qualification
-makeModuleQual qual mdl =
+makeModuleQual :: QualOption -> AbbreviationMap -> Module -> Qualification
+makeModuleQual qual abbrevs mdl =
   case qual of
-    OptLocalQual    -> LocalQual mdl
-    OptRelativeQual -> RelativeQual mdl
-    OptFullQual     -> FullQual
-    OptNoQual       -> NoQual
+    OptLocalQual      -> LocalQual mdl
+    OptRelativeQual   -> RelativeQual mdl
+    OptAbbreviateQual -> AbbreviateQual abbrevs mdl
+    OptFullQual       -> FullQual
+    OptNoQual         -> NoQual
 
 
 -----------------------------------------------------------------------------