From 99980dcc63d696c7912ff1f0d2faadcce169f184 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 5 Jul 2015 17:06:36 +0200
Subject: Refactor source path mapping to use modules as indices.
---
haddock-api/src/Haddock.hs | 27 ++++++++++------
haddock-api/src/Haddock/Backends/Hyperlinker.hs | 15 ++++-----
.../src/Haddock/Backends/Hyperlinker/Renderer.hs | 36 ++++++++++------------
haddock-api/src/Haddock/InterfaceFile.hs | 11 ++++---
haddock-api/src/Haddock/Types.hs | 9 +++++-
5 files changed, 55 insertions(+), 43 deletions(-)
(limited to 'haddock-api')
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 5a1c6abe..5c48d28b 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -46,6 +46,7 @@ import Data.List (isPrefixOf)
import Control.Exception
import Data.Maybe
import Data.IORef
+import Data.Map (Map)
import qualified Data.Map as Map
import System.IO
import System.Exit
@@ -228,13 +229,14 @@ renderStep dflags flags qual pkgs interfaces = do
let
ifaceFiles = map snd pkgs
installedIfaces = concatMap ifInstalledIfaces ifaceFiles
- srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ]
- render dflags flags qual interfaces installedIfaces srcMap
+ extSrcMap = Map.fromList
+ [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ]
+ render dflags flags qual interfaces installedIfaces extSrcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render dflags flags qual ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
+render dflags flags qual ifaces installedIfaces extSrcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -264,15 +266,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do
| Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
| otherwise = srcModule
- srcMap'
+ srcMap = Map.union
+ (Map.map SrcExternal extSrcMap)
+ (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
+
+ pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap
+ pkgSrcMap'
| Flag_HyperlinkedSource `elem` flags =
- Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap
- | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
- | otherwise = srcMap
+ Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
+ | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap
+ | otherwise = pkgSrcMap
-- TODO: Get these from the interface files as with srcMap
srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
- sourceUrls' = (srcBase, srcModule', srcMap', srcLMap')
+ sourceUrls' = (srcBase, srcModule', pkgSrcMap', srcLMap')
libDir <- getHaddockLibDir flags
prologue <- getPrologue dflags flags
@@ -322,7 +329,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
libDir
when (Flag_HyperlinkedSource `elem` flags) $ do
- ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces
+ 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
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 1fadef49..f007f970 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -8,7 +8,6 @@ import Haddock.Backends.Hyperlinker.Renderer
import Haddock.Backends.Hyperlinker.Utils
import Text.XHtml hiding ((</>))
-import GHC
import Data.Maybe
import System.Directory
@@ -24,30 +23,28 @@ ppHyperlinkedSource :: FilePath -- ^ Output directory
-> FilePath -- ^ Resource directory
-> Maybe FilePath -- ^ Custom CSS file path
-> Bool -- ^ Flag indicating whether to pretty-print HTML
- -> PackageKey -- ^ Package for which we create source
- -> SrcMap -- ^ Paths to external sources
+ -> SrcMap -- ^ Paths to sources
-> [Interface] -- ^ Interfaces for which we create source
-> IO ()
-ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do
createDirectoryIfMissing True srcdir
let cssFile = fromMaybe (defaultCssFile libdir) mstyle
copyFile cssFile $ srcdir </> srcCssFile
copyFile (libdir </> "html" </> highlightScript) $
srcdir </> highlightScript
- mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces
+ mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces
where
srcdir = outdir </> hypSrcDir
-- | Generate hyperlinked source for particular interface.
-ppHyperlinkedModuleSource :: FilePath -> Bool
- -> PackageKey -> SrcMap -> Interface
+ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface
-> IO ()
-ppHyperlinkedModuleSource srcdir pretty pkg srcs iface =
+ppHyperlinkedModuleSource srcdir pretty srcs iface =
case ifaceTokenizedSrc iface of
Just tokens -> writeFile path . html . render' $ tokens
Nothing -> return ()
where
- render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
+ render' = render (Just srcCssFile) (Just highlightScript) srcs
html = if pretty then renderHtml else showHtml
path = srcdir </> hypSrcModuleFile (ifaceMod iface)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index ddb2e5b9..a4d7bc2d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -23,10 +23,9 @@ import qualified Text.XHtml as Html
type StyleClass = String
-render :: Maybe FilePath -> Maybe FilePath
- -> GHC.PackageKey -> SrcMap -> [RichToken]
+render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
-> Html
-render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
+render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens
data TokenGroup
@@ -53,11 +52,11 @@ groupTokens ((RichToken tok (Just det)):rest) =
same _ = False
-body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
-body pkg srcs tokens =
+body :: SrcMap -> [RichToken] -> Html
+body srcs tokens =
Html.body . Html.pre $ hypsrc
where
- hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens
+ hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
header :: Maybe FilePath -> Maybe FilePath -> Html
@@ -79,13 +78,13 @@ header mcss mjs =
]
-tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html
-tokenGroup _ _ (GrpNormal tok) =
+tokenGroup :: SrcMap -> TokenGroup -> Html
+tokenGroup _ (GrpNormal tok) =
tokenSpan tok ! attrs
where
attrs = [ multiclass . tokenStyle . tkType $ tok ]
-tokenGroup pkg srcs (GrpRich det tokens) =
- externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
+tokenGroup srcs (GrpRich det tokens) =
+ externalAnchor det . internalAnchor det . hyperlink srcs det $ content
where
content = mconcat . map (richToken det) $ tokens
@@ -140,28 +139,27 @@ externalAnchorIdent = hypSrcNameUrl
internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
-hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
-hyperlink pkg srcs details = case rtkName details of
+hyperlink :: SrcMap -> TokenDetails -> Html -> Html
+hyperlink srcs details = case rtkName details of
Left name ->
if GHC.isInternalName name
then internalHyperlink name
- else externalNameHyperlink pkg srcs name
+ else externalNameHyperlink srcs name
Right name -> externalModHyperlink name
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
-externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink pkg srcs name content
- | namePkg == pkg = Html.anchor content !
+externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
+externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
+ Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleNameUrl mdl name ]
- | Just path <- Map.lookup namePkg srcs = Html.anchor content !
+ Just (SrcExternal path) -> Html.anchor content !
[ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
- | otherwise = content
+ Nothing -> content
where
mdl = GHC.nameModule name
- namePkg = GHC.modulePackageKey mdl
-- TODO: Implement module hyperlinks.
--
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 4b39d315..d5762ce8 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
-- Reading and writing the .haddock interface file
-----------------------------------------------------------------------------
module Haddock.InterfaceFile (
- InterfaceFile(..), ifPackageKey,
+ InterfaceFile(..), ifModule, ifPackageKey,
readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
) where
@@ -51,11 +51,14 @@ data InterfaceFile = InterfaceFile {
}
-ifPackageKey :: InterfaceFile -> PackageKey
-ifPackageKey if_ =
+ifModule :: InterfaceFile -> Module
+ifModule if_ =
case ifInstalledIfaces if_ of
[] -> error "empty InterfaceFile"
- iface:_ -> modulePackageKey $ instMod iface
+ iface:_ -> instMod iface
+
+ifPackageKey :: InterfaceFile -> PackageKey
+ifPackageKey = modulePackageKey . ifModule
binaryInterfaceMagic :: Word32
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index fbb5f44c..da4b3eec 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -50,7 +50,7 @@ type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
type InstMap = Map SrcSpan Name
type FixMap = Map Name Fixity
-type SrcMap = Map PackageKey FilePath
+type SrcMap = Map Module SrcPath
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -271,6 +271,13 @@ unrenameDocForDecl (doc, fnArgsDoc) =
-- | Type of environment used to cross-reference identifiers in the syntax.
type LinkEnv = Map Name Module
+-- | Path for making cross-package hyperlinks in generated sources.
+--
+-- Used in 'SrcMap' to determine whether module originates in current package
+-- or in an external package.
+data SrcPath
+ = SrcExternal FilePath
+ | SrcLocal
-- | Extends 'Name' with cross-reference information.
data DocName
--
cgit v1.2.3