From 979ada5bc63cba38bf570f943a3666298879bdc9 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 1 Apr 2012 22:03:25 +0200 Subject: '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. --- src/Haddock/Backends/Xhtml.hs | 3 ++- src/Haddock/Backends/Xhtml/Names.hs | 22 +++++++++++++++------ src/Haddock/Interface/Create.hs | 14 +++++++++++++ src/Haddock/Options.hs | 17 ++++++++-------- src/Haddock/Types.hs | 39 ++++++++++++++++++++++++------------- 5 files changed, 67 insertions(+), 28 deletions(-) (limited to 'src') 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 ----------------------------------------------------------------------------- -- cgit v1.2.3