aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Xhtml.hs3
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs22
-rw-r--r--src/Haddock/Interface/Create.hs35
-rw-r--r--src/Haddock/Options.hs17
-rw-r--r--src/Haddock/Types.hs39
5 files changed, 88 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..863e5f90 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 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..b9ca6d8c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -30,6 +30,9 @@ import Control.Applicative
import Control.Monad
import qualified Data.Traversable as T
+import qualified Packages
+import qualified Module
+import qualified SrcLoc
import GHC hiding (flags)
import HscTypes
import Name
@@ -106,6 +109,9 @@ createInterface tm flags modMap instIfaceMap = do
| OptPrune `elem` opts = prunedExportItems0
| otherwise = exportItems
+ let abbrevs =
+ mkAbbrevMap dflags $ tm_renamed_source tm
+
return Interface {
ifaceMod = mdl,
ifaceOrigFilename = msHsFilePath ms,
@@ -123,10 +129,39 @@ createInterface tm flags modMap instIfaceMap = do
ifaceVisibleExports = visibleNames,
ifaceDeclMap = declMap,
ifaceSubMap = subMap,
+ ifaceModuleAbbrevs = abbrevs,
ifaceInstances = instances,
ifaceHaddockCoverage = coverage
}
+mkAbbrevMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAbbrevMap dflags mRenamedSource =
+ case mRenamedSource of
+ Nothing -> M.empty
+ Just (_,impDecls,_,_) ->
+ M.fromList $
+ mapMaybe (\(SrcLoc.L _ impDecl) -> do
+ abbrev <- ideclAs impDecl
+ return $
+ (lookupModuleDyn dflags
+ (fmap Module.fsToPackageId $
+ ideclPkgQual impDecl)
+ (case ideclName impDecl of SrcLoc.L _ name -> name),
+ abbrev))
+ impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+ DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+ Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+ flip Module.mkModule mdlName $
+ case filter snd $
+ Packages.lookupModuleInAllPackages dflags mdlName of
+ (pkgId,_):_ -> Packages.packageConfigId pkgId
+ [] -> Module.mainPackageId
+
-------------------------------------------------------------------------------
-- Warnings
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..7a6d7bb9 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 Module 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
-----------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-28 19:44:16 +0000