diff options
Diffstat (limited to 'haddock-api/src/Haddock.hs')
| -rw-r--r-- | haddock-api/src/Haddock.hs | 89 |
1 files changed, 67 insertions, 22 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 942798eb..5526a0fa 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -35,6 +35,7 @@ import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Backends.Hyperlinker +import Haddock.Backends.Org import Haddock.Interface import Haddock.Interface.Json import Haddock.Parser @@ -65,7 +66,7 @@ import System.FilePath import System.Environment (getExecutablePath) #else import qualified GHC.Paths as GhcPaths -import Paths_haddock_api (getDataDir) +import Paths_haddorg_api (getDataDir) #endif import System.Directory (doesDirectoryExist, getTemporaryDirectory) @@ -203,11 +204,17 @@ haddockWithGhc ghc args = handleTopExceptions $ do if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files + let packageInfo = PackageInfo { piPackageName = + fromMaybe (PackageName mempty) (optPackageName flags) + , piPackageVersion = + fromMaybe (makeVersion []) (optPackageVersion flags) + } -- Dump an "interface file" (.haddock file), if requested. forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do writeInterfaceFile path InterfaceFile { ifInstalledIfaces = map toInstalledIface ifaces + , ifPackageInfo = packageInfo , ifLinkEnv = homeLinks } @@ -215,7 +222,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces else do - when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ + when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX, Flag_Org]) flags) $ throwE "No input file(s)." -- Get packages supplied with --read-interface. @@ -259,7 +266,7 @@ withGhc flags action = do readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv) + -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags @@ -267,28 +274,28 @@ readPackagesAndProcessModules flags files = do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages + let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles return (packages, ifaces, homeLinks) renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption - -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO () + -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do - updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) -> + updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> fst docPath Just url -> url </> packageName (ifUnitId ifaceFile) , ifaceFile)) pkgs) let installedIfaces = - concatMap - (\(_, ifaceFilePath, ifaceFile) - -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile) + map + (\(_, showModules, ifaceFilePath, ifaceFile) + -> (ifaceFilePath, mkPackageInterfaces showModules ifaceFile)) pkgs extSrcMap = Map.fromList $ do - ((_, Just path), _, ifile) <- pkgs + ((_, Just path), _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap @@ -306,6 +313,12 @@ render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption - render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let + packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) + $ optPackageName flags + , piPackageVersion = fromMaybe (makeVersion []) + $ optPackageVersion flags + } + title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags @@ -324,9 +337,32 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] - -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ map snd installedIfaces - allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] + -- /All/ interfaces including external package modules, grouped by + -- interface file (package). + allPackages :: [PackageInterfaces] + allPackages = [PackageInterfaces + { piPackageInfo = packageInfo + , piVisibility = Visible + , piInstalledInterfaces = map toInstalledIface ifaces + }] + ++ map snd packages + + -- /All/ visible interfaces including external package modules, grouped by + -- interface file (package). + allVisiblePackages :: [PackageInterfaces] + allVisiblePackages = [ pinfo { piInstalledInterfaces = + filter (\i -> OptHide `notElem` instOptions i) + piInstalledInterfaces + } + | pinfo@PackageInterfaces + { piVisibility = Visible + , piInstalledInterfaces + } <- allPackages + ] + + -- /All/ installed interfaces. + allInstalledIfaces :: [InstalledInterface] + allInstalledIfaces = concatMap (piInstalledInterfaces . snd) packages pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod @@ -370,7 +406,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') installedMap :: Map Module InstalledInterface - installedMap = Map.fromList [ (unwire (instMod iface), iface) | (_, iface) <- installedIfaces ] + installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- allInstalledIfaces ] -- The user gives use base-4.9.0.0, but the InstalledInterface -- records the *wired in* identity base. So untranslate it @@ -406,7 +442,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls - allVisibleIfaces pretty + withQuickjump + (concatMap piInstalledInterfaces allVisiblePackages) pretty return () unless withBaseURL $ @@ -417,7 +454,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc _ <- {-# SCC ppHtmlContents #-} ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty + withQuickjump + allVisiblePackages True prologue pretty sincePkg (makeContentsQual qual) return () copyHtmlBits odir libDir themes withQuickjump @@ -426,7 +464,10 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc ppJsonIndex odir sourceUrls' opt_wiki_urls unicode Nothing qual ifaces - (nub $ map fst installedIfaces) + ( nub + . map fst + . filter ((== Visible) . piVisibility . snd) + $ packages) when (Flag_Html `elem` flags) $ do withTiming logger "ppHtml" (const ()) $ do @@ -434,8 +475,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url - opt_contents_url opt_index_url unicode sincePkg qual - pretty withQuickjump + opt_contents_url opt_index_url unicode sincePkg packageInfo + qual pretty withQuickjump return () unless withBaseURL $ do copyHtmlBits odir libDir themes withQuickjump @@ -470,6 +511,10 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () + when (Flag_Org `elem` flags) $ do + withTiming logger dflags' "ppOrg" (const ()) $ do + let org = {-# SCC ppOrg #-} ppOrg title (_doc <$> prologue) (fromJust pkgStr) visibleIfaces + writeUtf8File (fromMaybe "haddock" (cleanPkgStr <$> pkgStr) <.> "org") org when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do withTiming logger "ppHyperlinkedSource" (const ()) $ do @@ -498,7 +543,8 @@ readInterfaceFiles name_cache pairs bypass_version_check = do putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return (Just (paths, file, f)) + Right f -> + return (Just (paths, showModules, file, f )) ------------------------------------------------------------------------------- @@ -744,4 +790,3 @@ getPrologue dflags flags = rightOrThrowE :: Either String b -> IO b rightOrThrowE (Left msg) = throwE msg rightOrThrowE (Right x) = pure x - |