aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs11
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs29
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs52
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs48
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs14
-rw-r--r--haddock-api/src/Haddock/Utils.hs8
6 files changed, 85 insertions, 77 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 3105edf5..d596c075 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -260,14 +260,13 @@ render dflags flags qual ifaces installedIfaces srcMap = do
(srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
srcModule'
- | isJust srcModule = srcModule
- | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl
- | otherwise = Nothing
+ | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
+ | otherwise = srcModule
srcMap'
- | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
| Flag_HyperlinkedSource `elem` flags =
- Map.insert pkgKey defaultNameSourceUrl srcMap
+ Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap
+ | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
| otherwise = srcMap
-- TODO: Get these from the interface files as with srcMap
@@ -322,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
libDir
when (Flag_HyperlinkedSource `elem` flags) $ do
- ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces
+ ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
-- | 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 6c66e0c6..f197eaa3 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,8 +1,9 @@
-module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
+module Haddock.Backends.Hyperlinker
+ ( ppHyperlinkedSource
+ , module Haddock.Backends.Hyperlinker.Utils
+ ) where
import Haddock.Types
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
import Haddock.Backends.Hyperlinker.Renderer
import Haddock.Backends.Hyperlinker.Utils
@@ -14,36 +15,30 @@ import System.FilePath
ppHyperlinkedSource :: FilePath -> FilePath
-> Maybe FilePath
- -> SourceURLs
-> [Interface]
-> IO ()
-ppHyperlinkedSource outdir libdir mstyle urls ifaces = do
+ppHyperlinkedSource outdir libdir mstyle ifaces = do
createDirectoryIfMissing True srcdir
let cssFile = fromMaybe (defaultCssFile libdir) mstyle
copyFile cssFile $ srcdir </> srcCssFile
copyFile (libdir </> "html" </> highlightScript) $
srcdir </> highlightScript
- mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces
+ mapM_ (ppHyperlinkedModuleSource srcdir) ifaces
where
- srcdir = srcPath outdir urls
+ srcdir = outdir </> hypSrcDir
-ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO ()
-ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of
+ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
+ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of
Just tokens ->
- writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens
+ writeFile path $ showHtml . render mCssFile mJsFile $ tokens
Nothing -> return ()
where
mCssFile = Just $ srcCssFile
mJsFile = Just $ highlightScript
- srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $
- srcModUrl urls
- path = outdir </> srcFile
-
-srcPath :: FilePath -> SourceURLs -> FilePath
-srcPath outdir urls = outdir </> takeDirectory (srcModUrl urls)
+ path = srcdir </> hypSrcModuleFile (ifaceMod iface)
srcCssFile :: FilePath
-srcCssFile = "srcstyle.css"
+srcCssFile = "style.css"
highlightScript :: FilePath
highlightScript = "highlight.js"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 2df62938..d8ea5ec7 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -3,15 +3,12 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Ast
import Haddock.Backends.Hyperlinker.Utils
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
import qualified GHC
import qualified Name as GHC
import qualified Unique as GHC
import Data.List
-import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
@@ -20,11 +17,11 @@ import qualified Text.XHtml as Html
type StyleClass = String
-render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html
-render mcss mjs urls tokens = header mcss mjs <> body urls tokens
+render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
+render mcss mjs tokens = header mcss mjs <> body tokens
-body :: SourceURLs -> [RichToken] -> Html
-body urls = Html.body . Html.pre . mconcat . map (richToken urls)
+body :: [RichToken] -> Html
+body = Html.body . Html.pre . mconcat . map richToken
header :: Maybe FilePath -> Maybe FilePath -> Html
header mcss mjs
@@ -39,18 +36,18 @@ header mcss mjs =
, Html.href cssFile
]
js Nothing = Html.noHtml
- js (Just jsFile) = Html.script Html.noHtml !
+ js (Just scriptFile) = Html.script Html.noHtml !
[ Html.thetype "text/javascript"
- , Html.src jsFile
+ , Html.src scriptFile
]
-richToken :: SourceURLs -> RichToken -> Html
-richToken _ (RichToken tok Nothing) =
+richToken :: RichToken -> Html
+richToken (RichToken tok Nothing) =
tokenSpan tok ! attrs
where
attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken urls (RichToken tok (Just det)) =
- externalAnchor det . internalAnchor det . hyperlink urls det $ content
+richToken (RichToken tok (Just det)) =
+ externalAnchor det . internalAnchor det . hyperlink det $ content
where
content = tokenSpan tok ! [ multiclass style]
style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -92,37 +89,30 @@ internalAnchor (RtkBind name) content =
internalAnchor _ content = content
externalAnchorIdent :: GHC.Name -> String
-externalAnchorIdent = GHC.occNameString . GHC.nameOccName
+externalAnchorIdent = hypSrcNameUrl
internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
-hyperlink :: SourceURLs -> TokenDetails -> Html -> Html
-hyperlink urls details = case rtkName details of
+hyperlink :: TokenDetails -> Html -> Html
+hyperlink details = case rtkName details of
Left name ->
if GHC.isInternalName name
then internalHyperlink name
- else externalNameHyperlink urls name
+ else externalNameHyperlink name
Right name -> externalModHyperlink name
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
-externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html
-externalNameHyperlink urls name =
- case Map.lookup key $ srcNameUrlMap urls of
- Just url -> externalNameHyperlink' url name
- Nothing -> id
+externalNameHyperlink :: GHC.Name -> Html -> Html
+externalNameHyperlink name content =
+ Html.anchor content ! [ Html.href href ]
where
- key = GHC.modulePackageKey . GHC.nameModule $ name
-
-externalNameHyperlink' :: String -> GHC.Name -> Html -> Html
-externalNameHyperlink' url name content =
- Html.anchor content ! [ Html.href $ href ]
- where
- mdl = GHC.nameModule name
- href = spliceURL Nothing (Just mdl) (Just name) Nothing url
+ href = hypSrcModuleNameUrl (GHC.nameModule name) name
externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink _ = id -- TODO
+externalModHyperlink mdl content =
+ Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 25ed942b..9ba8446d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -1,18 +1,46 @@
module Haddock.Backends.Hyperlinker.Utils
- ( srcModUrl
- , srcNameUrlMap
+ ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
+ , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl
+ , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat,
) where
-import Haddock.Utils
-import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
import GHC
+import System.FilePath.Posix ((</>))
-import Data.Maybe
-import Data.Map (Map)
-srcModUrl :: SourceURLs -> String
-srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl
+hypSrcDir :: FilePath
+hypSrcDir = "src"
-srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath
-srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap
+hypSrcModuleFile :: Module -> FilePath
+hypSrcModuleFile = hypSrcModuleFile' . moduleName
+
+hypSrcModuleFile' :: ModuleName -> FilePath
+hypSrcModuleFile' mdl = spliceURL'
+ Nothing (Just mdl) Nothing Nothing moduleFormat
+
+hypSrcModuleUrl :: Module -> String
+hypSrcModuleUrl = hypSrcModuleFile
+
+hypSrcModuleUrl' :: ModuleName -> String
+hypSrcModuleUrl' = hypSrcModuleFile'
+
+hypSrcNameUrl :: Name -> String
+hypSrcNameUrl name = spliceURL
+ Nothing Nothing (Just name) Nothing nameFormat
+
+hypSrcModuleNameUrl :: Module -> Name -> String
+hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
+
+hypSrcModuleUrlFormat :: String
+hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
+
+hypSrcModuleNameUrlFormat :: String
+hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
+
+moduleFormat :: String
+moduleFormat = "%{MODULE}.html"
+
+nameFormat :: String
+nameFormat = "%{NAME}"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index cbcbbd6d..36ecf863 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Utils (
renderToString,
namedAnchor, linkedAnchor,
- spliceURL,
+ spliceURL, spliceURL',
groupId,
(<+>), (<=>), char,
@@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils (
) where
-import Haddock.GhcUtils
import Haddock.Utils
import Data.Maybe
@@ -38,18 +37,23 @@ import Text.XHtml hiding ( name, title, p, quote )
import qualified Text.XHtml as XHtml
import GHC ( SrcSpan(..), srcSpanStartLine, Name )
-import Module ( Module )
+import Module ( Module, ModuleName, moduleName, moduleNameString )
import Name ( getOccString, nameOccName, isValOcc )
spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
+spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod)
+
+
+spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name ->
+ Maybe SrcSpan -> String -> String
+spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
where
file = fromMaybe "" maybe_file
mdl = case maybe_mod of
Nothing -> ""
- Just m -> moduleString m
+ Just m -> moduleNameString m
(name, kind) =
case maybe_name of
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 047d9fd0..4fed3a1e 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -29,7 +29,6 @@ module Haddock.Utils (
moduleNameUrl, moduleNameUrl', moduleUrl,
nameAnchorId,
makeAnchorId,
- defaultModuleSourceUrl, defaultNameSourceUrl,
-- * Miscellaneous utilities
getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -278,13 +277,6 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
-- NB: '-' is legal in IDs, but we use it as the escape char
-defaultModuleSourceUrl :: String
-defaultModuleSourceUrl = "src/%{MODULE}.html"
-
-defaultNameSourceUrl :: String
-defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}"
-
-
-------------------------------------------------------------------------------
-- * Files we need to copy from our $libdir
-------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 08:01:44 +0000