diff options
| -rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 6 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Names.hs | 39 | ||||
| -rw-r--r-- | src/Haddock/Options.hs | 4 | ||||
| -rw-r--r-- | src/Haddock/Types.hs | 7 |
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 |