From a2bcbcffde1e78a6031132bdf4a1a605978352a8 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 1 Apr 2012 13:03:07 +0200 Subject: add QualOption type for distinction between qualification argument given by the user and the actual qualification for a concrete module --- src/Haddock/Options.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'src/Haddock/Options.hs') diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 4e42fd32..3292ba16 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -229,13 +229,13 @@ optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] -qualification :: [Flag] -> Qualification +qualification :: [Flag] -> QualOption qualification flags = case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of - "full":_ -> FullQual - "local":_ -> LocalQual Nothing - "relative":_ -> RelativeQual Nothing - _ -> NoQual + "full":_ -> OptFullQual + "local":_ -> OptLocalQual + "relative":_ -> OptRelativeQual + _ -> OptNoQual verbosity :: [Flag] -> Verbosity -- cgit v1.2.3 From 29861370dd56f59557c3bcecd53fba0f88a89792 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 1 Apr 2012 16:25:02 +0200 Subject: emit an error message when the --qual option is used incorrectly --- src/Haddock/Options.hs | 13 ++++++++----- src/Main.hs | 6 +++++- 2 files changed, 13 insertions(+), 6 deletions(-) (limited to 'src/Haddock/Options.hs') diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 3292ba16..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] -> QualOption +qualification :: [Flag] -> Either String QualOption qualification flags = case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of - "full":_ -> OptFullQual - "local":_ -> OptLocalQual - "relative":_ -> OptRelativeQual - _ -> OptNoQual + [] -> 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/Main.hs b/src/Main.hs index e423cf03..7d83866a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -189,6 +189,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 @@ -198,7 +203,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 ] -- cgit v1.2.3 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/Haddock/Options.hs') 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 From 3eb6d272850950e4d0c41ed1169258e8c332dbed Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Mon, 2 Apr 2012 00:29:05 +0200 Subject: qualification style 'abbreviated' -> 'aliased' --- src/Haddock/Backends/Xhtml.hs | 4 ++-- src/Haddock/Backends/Xhtml/Names.hs | 6 +++--- src/Haddock/Interface/Create.hs | 14 +++++++------- src/Haddock/Options.hs | 4 ++-- src/Haddock/Types.hs | 16 ++++++++-------- 5 files changed, 22 insertions(+), 22 deletions(-) (limited to 'src/Haddock/Options.hs') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index fc94e7d6..94ca6d10 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -468,9 +468,9 @@ ppHtmlModule odir doctitle themes maybe_contents_url maybe_index_url unicode qual debug iface = do let mdl = ifaceMod iface - abbrevs = ifaceModuleAbbrevs iface + aliases = ifaceModuleAliases iface mdl_str = moduleString mdl - real_qual = makeModuleQual qual abbrevs mdl + real_qual = makeModuleQual qual aliases 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 863e5f90..48d0f7f1 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -79,10 +79,10 @@ ppQualifyName qual name mdl = Just _ -> ppFullQualName mdl name -- some other module, D.x -> D.x Nothing -> ppFullQualName mdl name - AbbreviateQual abbrevs localmdl -> + AliasedQual aliases localmdl -> case (moduleString mdl == moduleString localmdl, - M.lookup mdl abbrevs) of - (False, Just abbrev) -> ppQualName abbrev name + M.lookup mdl aliases) of + (False, Just alias) -> ppQualName alias name _ -> ppName name diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index b9ca6d8c..a0bfde42 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -109,8 +109,8 @@ createInterface tm flags modMap instIfaceMap = do | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems - let abbrevs = - mkAbbrevMap dflags $ tm_renamed_source tm + let aliases = + mkAliasMap dflags $ tm_renamed_source tm return Interface { ifaceMod = mdl, @@ -129,25 +129,25 @@ createInterface tm flags modMap instIfaceMap = do ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, ifaceSubMap = subMap, - ifaceModuleAbbrevs = abbrevs, + ifaceModuleAliases = aliases, ifaceInstances = instances, ifaceHaddockCoverage = coverage } -mkAbbrevMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -mkAbbrevMap dflags mRenamedSource = +mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap dflags mRenamedSource = case mRenamedSource of Nothing -> M.empty Just (_,impDecls,_,_) -> M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do - abbrev <- ideclAs impDecl + alias <- ideclAs impDecl return $ (lookupModuleDyn dflags (fmap Module.fsToPackageId $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), - abbrev)) + alias)) impDecls -- similar to GHC.lookupModule diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 792c0be3..46f9def7 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'\n'relative' or 'abbreviate'", + "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'", Option ['?'] ["help"] (NoArg Flag_Help) "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) @@ -237,7 +237,7 @@ qualification flags = ["full"] -> Right OptFullQual ["local"] -> Right OptLocalQual ["relative"] -> Right OptRelativeQual - ["abbreviate"] -> Right OptAbbreviateQual + ["aliased"] -> Right OptAliasedQual [arg] -> Left $ "unknown qualification type " ++ show arg _:_ -> Left "qualification option given multiple times" diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 7a6d7bb9..97d56a52 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -103,8 +103,8 @@ data Interface = Interface -- module. , ifaceVisibleExports :: ![Name] - -- | Abbreviations of module imports as in @import A.B.C as C@. - , ifaceModuleAbbrevs :: AbbreviationMap + -- | Aliases of module imports as in @import A.B.C as C@. + , ifaceModuleAliases :: AliasMap -- | Instances exported by the module. , ifaceInstances :: ![Instance] @@ -383,21 +383,21 @@ data QualOption | 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 + | OptAliasedQual -- ^ Uses aliases 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 +type AliasMap = Map Module ModuleName data Qualification = NoQual | FullQual | LocalQual Module | RelativeQual Module - | AbbreviateQual AbbreviationMap Module + | AliasedQual AliasMap Module -- ^ @Module@ contains the current module. -- This way we can distinguish imported and local identifiers. @@ -407,12 +407,12 @@ makeContentsQual qual = OptNoQual -> NoQual _ -> FullQual -makeModuleQual :: QualOption -> AbbreviationMap -> Module -> Qualification -makeModuleQual qual abbrevs mdl = +makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification +makeModuleQual qual aliases mdl = case qual of OptLocalQual -> LocalQual mdl OptRelativeQual -> RelativeQual mdl - OptAbbreviateQual -> AbbreviateQual abbrevs mdl + OptAliasedQual -> AliasedQual aliases mdl OptFullQual -> FullQual OptNoQual -> NoQual -- cgit v1.2.3