aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock.hs')
-rw-r--r--haddock-api/src/Haddock.hs134
1 files changed, 76 insertions, 58 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index f7fa52b3..00eb50f6 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
@@ -25,7 +25,6 @@ module Haddock (
withGhc
) where
-import Data.Version
import Haddock.Backends.Xhtml
import Haddock.Backends.Xhtml.Meta
import Haddock.Backends.Xhtml.Themes (getThemes)
@@ -42,7 +41,6 @@ import Haddock.Options
import Haddock.Utils
import Control.Monad hiding (forM_)
-import Control.Applicative
import Data.Foldable (forM_, foldl')
import Data.Traversable (for)
import Data.List (isPrefixOf)
@@ -151,7 +149,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
-- or which exits with an error or help message.
(flags, files) <- parseHaddockOpts args
shortcutFlags flags
- qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
+ qual <- rightOrThrowE (qualification flags)
+ sinceQual <- rightOrThrowE (sinceQualification flags)
-- inject dynamic-too into flags before we proceed
flags' <- ghc flags $ do
@@ -184,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep dflags flags qual packages ifaces
+ liftIO $ renderStep dflags flags sinceQual qual packages ifaces
else do
when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -194,7 +193,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags flags qual packages []
+ liftIO $ renderStep dflags flags sinceQual qual packages []
-- | Create warnings about potential misuse of -optghc
warnings :: [String] -> [String]
@@ -228,8 +227,9 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags flags qual pkgs interfaces = do
+renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption
+ -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs pkgs
let
ifaceFiles = map snd pkgs
@@ -238,12 +238,12 @@ renderStep dflags flags qual pkgs interfaces = do
((_, Just path), ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render dflags flags qual interfaces installedIfaces extSrcMap
-
+ render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
-render dflags flags qual ifaces installedIfaces extSrcMap = do
+render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]
+ -> [InstalledInterface] -> Map Module FilePath -> IO ()
+render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -270,6 +270,10 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
pkgKey = moduleUnitId pkgMod
pkgStr = Just (unitIdString pkgKey)
pkgNameVer = modulePackageInfo dflags flags pkgMod
+ pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)
+ sincePkg = case sinceQual of
+ External -> pkgName
+ Always -> Nothing
(srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
@@ -277,7 +281,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
| Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
| otherwise = srcModule
- srcMap = mkSrcMap $ Map.union
+ srcMap = Map.union
(Map.map SrcExternal extSrcMap)
(Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
@@ -323,24 +327,34 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
let withQuickjump = Flag_QuickJumpIndex `elem` flags
when (Flag_GenIndex `elem` flags) $ do
- ppHtmlIndex odir title pkgStr
- themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
- allVisibleIfaces pretty
+ withTiming (pure dflags') "ppHtmlIndex" (const ()) $ do
+ _ <- {-# SCC ppHtmlIndex #-}
+ ppHtmlIndex odir title pkgStr
+ themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
+ allVisibleIfaces pretty
+ return ()
+
copyHtmlBits odir libDir themes withQuickjump
when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents dflags' odir title pkgStr
- themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue pretty
- (makeContentsQual qual)
+ withTiming (pure dflags') "ppHtmlContents" (const ()) $ do
+ _ <- {-# SCC ppHtmlContents #-}
+ ppHtmlContents dflags' odir title pkgStr
+ themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
+ allVisibleIfaces True prologue pretty
+ sincePkg (makeContentsQual qual)
+ return ()
copyHtmlBits odir libDir themes withQuickjump
when (Flag_Html `elem` flags) $ do
- ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
- prologue
- themes opt_mathjax sourceUrls' opt_wiki_urls
- opt_contents_url opt_index_url unicode qual
- pretty withQuickjump
+ withTiming (pure dflags') "ppHtml" (const ()) $ do
+ _ <- {-# SCC ppHtml #-}
+ ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
+ prologue
+ themes opt_mathjax sourceUrls' opt_wiki_urls
+ opt_contents_url opt_index_url unicode sincePkg qual
+ pretty withQuickjump
+ return ()
copyHtmlBits odir libDir themes withQuickjump
writeHaddockMeta odir withQuickjump
@@ -348,7 +362,12 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
-- might want to fix that if/when these two get some work on them
when (Flag_Hoogle `elem` flags) $ do
case pkgNameVer of
- Nothing -> putStrLn . unlines $
+ (Just (PackageName pkgNameFS), Just pkgVer) ->
+ let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
+ | otherwise = unpackFS pkgNameFS
+ in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
+ visibleIfaces odir
+ _ -> putStrLn . unlines $
[ "haddock: Unable to find a package providing module "
++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle."
, ""
@@ -356,38 +375,19 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
++ " using the --package-name"
, " and --package-version arguments."
]
- Just (PackageName pkgNameFS, pkgVer) ->
- let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
- | otherwise = unpackFS pkgNameFS
- in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
- visibleIfaces odir
when (Flag_LaTeX `elem` flags) $ do
- ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
- libDir
+ withTiming (pure dflags') "ppLatex" (const ()) $ do
+ _ <- {-# SCC ppLatex #-}
+ ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
+ libDir
+ return ()
when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
- ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
-
--- | From GHC 7.10, this function has a potential to crash with a
--- nasty message such as @expectJust getPackageDetails@ because
--- package name and versions can no longer reliably be extracted in
--- all cases: if the package is not installed yet then this info is no
--- longer available. The @--package-name@ and @--package-version@
--- Haddock flags allow the user to specify this information and it is
--- returned here if present: if it is not present, the error will
--- occur. Nasty but that's how it is for now. Potential TODO.
-modulePackageInfo :: DynFlags
- -> [Flag] -- ^ Haddock flags are checked as they may
- -- contain the package name or version
- -- provided by the user which we
- -- prioritise
- -> Module -> Maybe (PackageName, Data.Version.Version)
-modulePackageInfo dflags flags modu =
- cmdline <|> pkgDb
- where
- cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags
- pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu)
+ withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do
+ _ <- {-# SCC ppHyperlinkedSource #-}
+ ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
+ return ()
-------------------------------------------------------------------------------
@@ -400,7 +400,7 @@ readInterfaceFiles :: MonadIO m
-> [(DocPaths, FilePath)]
-> m [(DocPaths, InterfaceFile)]
readInterfaceFiles name_cache_accessor pairs = do
- catMaybes `liftM` mapM tryReadIface pairs
+ catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) =
@@ -439,13 +439,26 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
_ <- setSessionDynFlags dynflags''
ghcActs dynflags''
where
+
+ -- ignore sublists of flags that start with "+RTS" and end in "-RTS"
+ --
+ -- See https://github.com/haskell/haddock/issues/666
+ filterRtsFlags :: [String] -> [String]
+ filterRtsFlags flgs = foldr go (const []) flgs True
+ where go "-RTS" func _ = func True
+ go "+RTS" func _ = func False
+ go _ func False = func False
+ go arg func True = arg : func True
+
+
parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
parseGhcFlags dynflags = do
-- TODO: handle warnings?
- (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags)
+ let flags' = filterRtsFlags flags
+ (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
if not (null rest)
- then throwE ("Couldn't parse GHC options: " ++ unwords flags)
+ then throwE ("Couldn't parse GHC options: " ++ unwords flags')
else return dynflags'
unsetPatternMatchWarnings :: DynFlags -> DynFlags
@@ -596,10 +609,15 @@ getPrologue dflags flags =
h <- openFile filename ReadMode
hSetEncoding h utf8
str <- hGetContents h -- semi-closes the handle
- return . Just $! parseParas dflags str
+ return . Just $! parseParas dflags Nothing str
_ -> throwE "multiple -p/--prologue options"
+rightOrThrowE :: Either String b -> IO b
+rightOrThrowE (Left msg) = throwE msg
+rightOrThrowE (Right x) = pure x
+
+
#ifdef IN_GHC_TREE
getInTreeDir :: IO String
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 03:46:38 +0000