From eada277a0f492e20d034ec6b8fb08a476232c7c4 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 5 Mar 2012 11:14:20 +0100 Subject: Save/restore global state for static flags when running GHC actions This is necessary if we want to run createInterfaces (from Documentation.Haddock) multiple times in the same process. --- src/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs index 0a3c9ffc..c0b7df4b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -57,6 +57,7 @@ import Paths_haddock import GHC hiding (flags, verbosity) import Config import DynFlags hiding (flags, verbosity) +import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) import Panic (panic, handleGhcException) import Module @@ -290,7 +291,7 @@ dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action. withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc libDir flags ghcActs = do +withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do -- TODO: handle warnings? (restFlags, _) <- parseStaticFlags (map noLoc flags) runGhc (Just libDir) $ do @@ -308,6 +309,7 @@ withGhc libDir flags ghcActs = do -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags''' ghcActs dynflags''' + `finally` restoreStaticFlagGlobals savedFlags where parseGhcFlags :: Monad m => DynFlags -> [Located String] -> [String] -> m DynFlags -- cgit v1.2.3 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/Backends/Xhtml.hs | 14 +++++--------- src/Haddock/Backends/Xhtml/Names.hs | 8 ++------ src/Haddock/Options.hs | 10 +++++----- src/Haddock/Types.hs | 32 +++++++++++++++++++++++++++----- src/Main.hs | 3 ++- 5 files changed, 41 insertions(+), 26 deletions(-) (limited to 'src/Main.hs') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 84468610..686bd36b 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -66,7 +66,7 @@ ppHtml :: String -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) - -> Qualification -- ^ How to qualify names + -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> IO () @@ -83,7 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue themes maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) False -- we don't want to display the packages in a single-package contents - prologue debug qual + prologue debug (makeContentsQual qual) when (isNothing maybe_index_url) $ ppHtmlIndex odir doctitle maybe_package @@ -461,7 +461,7 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool -> Qualification + -> Maybe String -> Maybe String -> Bool -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url @@ -469,10 +469,7 @@ ppHtmlModule odir doctitle themes let mdl = ifaceMod iface mdl_str = moduleString mdl - real_qual = case qual of - LocalQual Nothing -> LocalQual (Just mdl) - RelativeQual Nothing -> RelativeQual (Just mdl) - _ -> qual + real_qual = makeModuleQual qual mdl html = headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ bodyHtml doctitle (Just iface) @@ -484,8 +481,7 @@ ppHtmlModule odir doctitle themes createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) - ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug - + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes -> Interface -> Bool -> Qualification -> Bool -> IO () diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 274078a6..9963fffc 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -64,14 +64,10 @@ ppQualifyName qual name mdl = case qual of NoQual -> ppName name FullQual -> ppFullQualName mdl name - -- this is just in case, it should never happen - LocalQual Nothing -> ppQualifyName FullQual name mdl - LocalQual (Just localmdl) + LocalQual localmdl | moduleString mdl == moduleString localmdl -> ppName name | otherwise -> ppFullQualName mdl name - -- again, this never happens - RelativeQual Nothing -> ppQualifyName FullQual name mdl - RelativeQual (Just localmdl) -> + RelativeQual localmdl -> case List.stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppQualifyName NoQual name mdl 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 diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 22d2f6ae..de0cc3d9 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -374,12 +374,34 @@ 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. + data Qualification - = NoQual -- ^ Never qualify any names. - | FullQual -- ^ Qualify all names fully. - | LocalQual (Maybe Module) -- ^ Qualify all imported names fully. - | RelativeQual (Maybe Module) -- ^ Like local, but strip module prefix. - -- from modules in the same hierarchy. + = NoQual + | FullQual + | LocalQual Module + | RelativeQual Module + -- ^ @Maybe Module@ contains the current module. + -- This way we can distinguish imported and local identifiers. + +makeContentsQual :: QualOption -> Qualification +makeContentsQual qual = + case qual of + OptNoQual -> NoQual + _ -> FullQual + +makeModuleQual :: QualOption -> Module -> Qualification +makeModuleQual qual mdl = + case qual of + OptLocalQual -> LocalQual mdl + OptRelativeQual -> RelativeQual mdl + OptFullQual -> FullQual + OptNoQual -> NoQual ----------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index 0a3c9ffc..e423cf03 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -228,7 +228,8 @@ render flags ifaces installedIfaces srcMap = do when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty opt_qualification + allVisibleIfaces True prologue pretty + (makeContentsQual opt_qualification) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do -- 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/Main.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 162364b177c3982c67c842d310aead45434a3760 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 21:46:04 +0200 Subject: Check qualification option before processing modules. --- src/Main.hs | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs index 4f0784eb..8c15661d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -127,9 +127,13 @@ main :: IO () main = handleTopExceptions $ do -- Parse command-line flags and handle some of them initially. + -- TODO: unify all of this (and some of what's in the 'render' function), + -- into one function that returns a record with a field for each option, + -- or which exits with an error or help message. args <- getArgs (flags, files) <- parseHaddockOpts args shortcutFlags flags + qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -140,7 +144,7 @@ main = handleTopExceptions $ do Nothing -> return () -- Render the interfaces. - renderStep flags packages ifaces + renderStep flags qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -150,7 +154,7 @@ main = handleTopExceptions $ do packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags) -- Render even though there are no input files (usually contents/index). - renderStep flags packages [] + renderStep flags qual packages [] readPackagesAndProcessModules :: [Flag] -> [String] @@ -176,24 +180,19 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep flags pkgs interfaces = do +renderStep :: [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep flags qual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] - render flags interfaces installedIfaces srcMap + render flags qual interfaces installedIfaces srcMap -- | Render the interfaces with whatever backend is specified in the flags. -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 +render :: [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render flags qual ifaces installedIfaces srcMap = do let title = fromMaybe "" (optTitle flags) @@ -234,14 +233,14 @@ render flags ifaces installedIfaces srcMap = do ppHtmlContents odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty - (makeContentsQual opt_qualification) + (makeContentsQual qual) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do ppHtml title pkgStr visibleIfaces odir prologue themes sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode opt_qualification + opt_contents_url opt_index_url unicode qual pretty copyHtmlBits odir libDir themes -- cgit v1.2.3