diff options
-rw-r--r-- | haddock-api/src/Haddock.hs | 27 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 15 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 36 | ||||
-rw-r--r-- | haddock-api/src/Haddock/InterfaceFile.hs | 11 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Types.hs | 9 |
5 files changed, 55 insertions, 43 deletions
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 |