From 62d44cd1d37d83fa93d169c2e5b5b758fcc231d6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 16:09:54 +0200 Subject: Create hyperlinker module and plug it into the Haddock pipeline. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker.hs (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs new file mode 100644 index 00000000..88619474 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -0,0 +1,25 @@ +module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where + +import Haddock.Types +import Haddock.Backends.Hyperlinker.Renderer + +import GHC +import Text.XHtml hiding (()) +import System.Directory +import System.FilePath + +ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] + -> IO () +ppHyperlinkedSource outdir libdir mstyle ifaces = do + createDirectoryIfMissing True (outdir "src") + mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces + +ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO () +ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of + Just tokens -> writeFile path $ showHtml . render mstyle $ tokens + Nothing -> return () + where + path = outdir "src" moduleSourceFile (ifaceMod iface) + +moduleSourceFile :: Module -> FilePath +moduleSourceFile = (++ ".html") . moduleNameString . moduleName -- cgit v1.2.3 From 6f16398a26a12d58b3ba7f1924e2b6b00e68f5f7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 17:20:37 +0200 Subject: Add support for providing custom CSS files for hyperlinked source. --- haddock-api/haddock-api.cabal | 1 + haddock-api/resources/html/solarized.css | 55 +++++++++++++++++++++++++ haddock-api/src/Haddock.hs | 3 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 26 +++++++++--- haddock-api/src/Haddock/Options.hs | 6 +++ 5 files changed, 84 insertions(+), 7 deletions(-) create mode 100644 haddock-api/resources/html/solarized.css (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 6ffde976..14656994 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -18,6 +18,7 @@ stability: experimental data-dir: resources data-files: + html/solarized.css html/frames.html html/haddock-util.js html/Classic.theme/haskell_icon.gif diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css new file mode 100644 index 00000000..e4bff385 --- /dev/null +++ b/haddock-api/resources/html/solarized.css @@ -0,0 +1,55 @@ +body { + background-color: #fdf6e3; +} + +.hs-identifier { + color: #073642; +} + +.hs-identifier.hs-var { +} + +.hs-identifier.hs-type { + color: #5f5faf; +} + +.hs-keyword { + color: #af005f; +} + +.hs-string, .hs-char { + color: #cb4b16; +} + +.hs-number { + color: #268bd2; +} + +.hs-operator { + color: #d33682; +} + +.hs-glyph, .hs-special { + color: #dc322f; +} + +.hs-comment { + color: #8a8a8a; +} + +.hs-pragma { + color: #2aa198; +} + +.hs-cpp { + color: #859900; +} + +a:link, a:visited { + text-decoration: none; + border-bottom: 1px solid #eee8d5; +} + +a:hover { + background-color: #eee8d5; +} diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index e45456ab..698122e3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -244,6 +244,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags + opt_source_css = optSourceCssFile flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -310,7 +311,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir Nothing 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 88619474..66392a67 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -5,21 +5,35 @@ import Haddock.Backends.Hyperlinker.Renderer import GHC import Text.XHtml hiding (()) + +import Data.Maybe import System.Directory import System.FilePath ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] -> IO () ppHyperlinkedSource outdir libdir mstyle ifaces = do - createDirectoryIfMissing True (outdir "src") - mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces + createDirectoryIfMissing True $ srcPath outdir + let cssFile = fromMaybe (defaultCssFile libdir) mstyle + copyFile cssFile $ srcPath outdir srcCssFile + mapM_ (ppHyperlinkedModuleSource outdir) ifaces -ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO () -ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mstyle $ tokens +ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () +ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of + Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens Nothing -> return () where - path = outdir "src" moduleSourceFile (ifaceMod iface) + mSrcCssFile = Just $ srcCssFile + path = srcPath outdir moduleSourceFile (ifaceMod iface) moduleSourceFile :: Module -> FilePath moduleSourceFile = (++ ".html") . moduleNameString . moduleName + +srcPath :: FilePath -> FilePath +srcPath outdir = outdir "src" + +srcCssFile :: FilePath +srcCssFile = "style.css" + +defaultCssFile :: FilePath -> FilePath +defaultCssFile libdir = libdir "html" "solarized.css" diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index c9d5688c..f84989ef 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -21,6 +21,7 @@ module Haddock.Options ( optContentsUrl, optIndexUrl, optCssFile, + optSourceCssFile, sourceUrls, wikiUrls, optDumpInterfaceFile, @@ -67,6 +68,7 @@ data Flag | Flag_LaTeX | Flag_LaTeXStyle String | Flag_HyperlinkedSource + | Flag_SourceCss String | Flag_Help | Flag_Verbosity String | Flag_Version @@ -119,6 +121,8 @@ options backwardsCompat = "output for Hoogle; you may want --package-name and --package-version too", Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) "generate highlighted and hyperlinked source code (for use with --html)", + Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") + "use custom CSS file instead of default one in hyperlinked source", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) @@ -242,6 +246,8 @@ optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ] optCssFile :: [Flag] -> Maybe FilePath optCssFile flags = optLast [ str | Flag_CSS str <- flags ] +optSourceCssFile :: [Flag] -> Maybe FilePath +optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ] sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) sourceUrls flags = -- cgit v1.2.3 From a6bd86a8550d5d7e8bdb12e1d09036b9f88eed73 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 17:41:31 +0200 Subject: Add support for fancy highlighting upon hovering over identifier. --- haddock-api/haddock-api.cabal | 1 + haddock-api/resources/html/highlight.js | 46 ++++++++++++++++++++++ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 10 ++++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 23 +++++++---- 4 files changed, 70 insertions(+), 10 deletions(-) create mode 100644 haddock-api/resources/html/highlight.js (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 14656994..216627cc 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -21,6 +21,7 @@ data-files: html/solarized.css html/frames.html html/haddock-util.js + html/highlight.js html/Classic.theme/haskell_icon.gif html/Classic.theme/minus.gif html/Classic.theme/plus.gif diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js new file mode 100644 index 00000000..639cf5d5 --- /dev/null +++ b/haddock-api/resources/html/highlight.js @@ -0,0 +1,46 @@ + +var styleForRule = function (rule) { + var sheets = document.styleSheets; + for (var s = 0; s < sheets.length; s++) { + var rules = sheets[s].cssRules; + for (var r = 0; r < rules.length; r++) { + if (rules[r].selectorText == rule) { + return rules[r].style; + } + } + } +}; + +var highlight = function () { + var color = styleForRule("a:hover")["background-color"]; + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = color; + } + } +}; + +/* + * I have no idea what is the proper antonym for "highlight" in this + * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously + * so I like it. + */ +var lowlight = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = ""; + } + } +}; + +window.onload = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + links[i].onmouseover = highlight; + links[i].onmouseout = lowlight; + } +}; diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 66392a67..9337307c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -16,14 +16,17 @@ ppHyperlinkedSource outdir libdir mstyle ifaces = do createDirectoryIfMissing True $ srcPath outdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcPath outdir srcCssFile + copyFile (libdir "html" highlightScript) $ + srcPath outdir highlightScript mapM_ (ppHyperlinkedModuleSource outdir) ifaces ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens + Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where - mSrcCssFile = Just $ srcCssFile + mCssFile = Just $ srcCssFile + mJsFile = Just $ highlightScript path = srcPath outdir moduleSourceFile (ifaceMod iface) moduleSourceFile :: Module -> FilePath @@ -35,5 +38,8 @@ srcPath outdir = outdir "src" srcCssFile :: FilePath srcCssFile = "style.css" +highlightScript :: FilePath +highlightScript = "highlight.js" + defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 70524759..6d6d2012 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -16,21 +16,28 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> [RichToken] -> Html -render css tokens = header css <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html +render mcss mjs tokens = header mcss mjs <> body tokens body :: [RichToken] -> Html body = Html.body . Html.pre . mconcat . map richToken -header :: Maybe FilePath -> Html -header Nothing = Html.noHtml -header (Just css) = - Html.header $ Html.thelink Html.noHtml ! attrs +header :: Maybe FilePath -> Maybe FilePath -> Html +header mcss mjs + | isNothing mcss && isNothing mjs = Html.noHtml +header mcss mjs = + Html.header $ css mcss <> js mjs where - attrs = + css Nothing = Html.noHtml + css (Just cssFile) = Html.thelink Html.noHtml ! [ Html.rel "stylesheet" - , Html.href css , Html.thetype "text/css" + , Html.href cssFile + ] + js Nothing = Html.noHtml + js (Just jsFile) = Html.script Html.noHtml ! + [ Html.thetype "text/javascript" + , Html.src jsFile ] richToken :: RichToken -> Html -- cgit v1.2.3 From affd889d1b192d2cb9787c92202317b9e9401922 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 21:13:12 +0200 Subject: Make source hyperlinker generate output in apropriate directory. --- haddock-api/src/Haddock.hs | 10 ++++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 41 +++++++++++++++---------- haddock-api/src/Haddock/Utils.hs | 5 +++ 3 files changed, 38 insertions(+), 18 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 698122e3..01e4cd45 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -258,10 +258,16 @@ render dflags flags qual ifaces installedIfaces srcMap = do pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags + + srcModule' + | isJust srcModule = srcModule + | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl + | otherwise = Nothing + srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity -- 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', srcMap', srcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags @@ -311,7 +317,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css sourceUrls' 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 9337307c..2ed4dbdd 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,45 +1,54 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types +import Haddock.Utils +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer -import GHC import Text.XHtml hiding (()) import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] +ppHyperlinkedSource :: FilePath -> FilePath + -> Maybe FilePath + -> SourceURLs + -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle ifaces = do - createDirectoryIfMissing True $ srcPath outdir +ppHyperlinkedSource outdir libdir mstyle urls ifaces = do + createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle - copyFile cssFile $ srcPath outdir srcCssFile + copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ - srcPath outdir highlightScript - mapM_ (ppHyperlinkedModuleSource outdir) ifaces + srcdir highlightScript + mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces + where + srcdir = srcPath outdir urls -ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () -ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of +ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () +ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile mJsFile = Just $ highlightScript - path = srcPath outdir moduleSourceFile (ifaceMod iface) - -moduleSourceFile :: Module -> FilePath -moduleSourceFile = (++ ".html") . moduleNameString . moduleName + srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $ + srcModUrl urls + path = outdir srcFile -srcPath :: FilePath -> FilePath -srcPath outdir = outdir "src" +srcPath :: FilePath -> SourceURLs -> FilePath +srcPath outdir urls = outdir takeDirectory (srcModUrl urls) srcCssFile :: FilePath -srcCssFile = "style.css" +srcCssFile = "srcstyle.css" highlightScript :: FilePath highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" + +srcModUrl :: SourceURLs -> String +srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..78c78aca 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,6 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, + defaultModuleSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -277,6 +278,10 @@ 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" + + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir ------------------------------------------------------------------------------- -- cgit v1.2.3 From d58bcf24dfa4333e7893935eb86c036be28125b1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:41:07 +0200 Subject: Make external hyperlinks point to locations specified by source URLs. --- haddock-api/src/Haddock.hs | 7 ++- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 8 ++-- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 5 ++- 4 files changed, 44 insertions(+), 28 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 01e4cd45..3105edf5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -264,7 +264,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl | otherwise = Nothing - srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity + srcMap' + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap + | Flag_HyperlinkedSource `elem` flags = + Map.insert pkgKey defaultNameSourceUrl srcMap + | otherwise = srcMap + -- 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') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 2ed4dbdd..6c66e0c6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,10 +1,10 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types -import Haddock.Utils import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) @@ -29,7 +29,8 @@ ppHyperlinkedSource outdir libdir mstyle urls ifaces = do ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens + Just tokens -> + writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile @@ -49,6 +50,3 @@ highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" - -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 6d6d2012..2df62938 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -2,12 +2,16 @@ 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 @@ -16,11 +20,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html +render mcss mjs urls tokens = header mcss mjs <> body urls tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: SourceURLs -> [RichToken] -> Html +body urls = Html.body . Html.pre . mconcat . map (richToken urls) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -40,13 +44,13 @@ header mcss mjs = , Html.src jsFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: SourceURLs -> RichToken -> Html +richToken _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken urls (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink urls det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -93,26 +97,32 @@ externalAnchorIdent = GHC.occNameString . GHC.nameOccName internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: SourceURLs -> TokenDetails -> Html -> Html +hyperlink urls details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalHyperlink mname (Just name) - where - mname = GHC.moduleName <$> GHC.nameModule_maybe name - Right name -> externalHyperlink (Just name) Nothing + else externalNameHyperlink urls name + Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html -externalHyperlink mmname miname content = - Html.anchor content ! [ Html.href $ path ++ anchor ] +externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html +externalNameHyperlink urls name = + case Map.lookup key $ srcNameUrlMap urls of + Just url -> externalNameHyperlink' url name + Nothing -> id where - path = fromMaybe "" $ modulePath <$> mmname - anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + key = GHC.modulePackageKey . GHC.nameModule $ name -modulePath :: GHC.ModuleName -> String -modulePath name = GHC.moduleNameString name ++ ".html" +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 + +externalModHyperlink :: GHC.ModuleName -> Html -> Html +externalModHyperlink _ = id -- TODO diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 78c78aca..047d9fd0 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, + defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -281,6 +281,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r defaultModuleSourceUrl :: String defaultModuleSourceUrl = "src/%{MODULE}.html" +defaultNameSourceUrl :: String +defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir -- cgit v1.2.3 From ab070206d67748232995a262b533957a5a7b9315 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 27 Jun 2015 18:03:56 +0200 Subject: Rewrite source generation to fixed links and directory structure. --- haddock-api/src/Haddock.hs | 11 +++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 29 +++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++------------- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 48 +++++++++++++++----- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 14 +++--- haddock-api/src/Haddock/Utils.hs | 8 ---- 6 files changed, 85 insertions(+), 77 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') 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 ------------------------------------------------------------------------------- -- cgit v1.2.3 From a6eb5a19b13bc4dfa79d0e55e5992dfa403aa3c3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:00:55 +0200 Subject: Add basic support for cross-package hyperlink generation. --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 ++++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 42 +++++++++++++--------- 3 files changed, 40 insertions(+), 29 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d596c075..caaa1eef 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap 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 f197eaa3..f2caa2c1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -8,33 +8,34 @@ import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) +import GHC import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath - -> Maybe FilePath - -> [Interface] +ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath + -> PackageKey -> SrcMap -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle ifaces = do +ppHyperlinkedSource outdir libdir mstyle pkg 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) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces where srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () -ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of - Just tokens -> - writeFile path $ showHtml . render mCssFile mJsFile $ tokens - Nothing -> return () +ppHyperlinkedModuleSource :: FilePath + -> PackageKey -> SrcMap -> Interface + -> IO () +ppHyperlinkedModuleSource srcdir pkg srcs iface = + case ifaceTokenizedSrc iface of + Just tokens -> writeFile path . showHtml . render' $ tokens + Nothing -> return () where - mCssFile = Just $ srcCssFile - mJsFile = Just $ highlightScript + render' = render (Just srcCssFile) (Just highlightScript) pkg srcs path = srcdir hypSrcModuleFile (ifaceMod iface) srcCssFile :: FilePath diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index d8ea5ec7..b05a5b8a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,5 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where +import Haddock.Types import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast import Haddock.Backends.Hyperlinker.Utils @@ -8,20 +9,25 @@ import qualified GHC import qualified Name as GHC import qualified Unique as GHC +import System.FilePath.Posix (()) + import Data.List import Data.Maybe import Data.Monoid +import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath + -> GHC.PackageKey -> SrcMap -> [RichToken] + -> Html +render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html +body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -41,13 +47,13 @@ header mcss mjs = , Html.src scriptFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html +richToken _ _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken pkg srcs (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -94,25 +100,29 @@ externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html +hyperlink pkg srcs details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink name + else externalNameHyperlink pkg srcs name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: GHC.Name -> Html -> Html -externalNameHyperlink name content = - Html.anchor content ! [ Html.href href ] +externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink pkg srcs name content + | namePkg == pkg = Html.anchor content ! + [ Html.href $ hypSrcModuleNameUrl mdl name ] + | Just path <- Map.lookup namePkg srcs = Html.anchor content ! + [ Html.href $ path hypSrcModuleNameUrl mdl name ] + | otherwise = content where - href = hypSrcModuleNameUrl (GHC.nameModule name) name + mdl = GHC.nameModule name + namePkg = GHC.modulePackageKey mdl externalModHyperlink :: GHC.ModuleName -> Html -> Html externalModHyperlink mdl content = Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] - -- cgit v1.2.3 From 6bebd572bc673d10ed68096f935cdc5a9d1839b5 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 21:58:08 +0200 Subject: Make hyperlinker respect pretty-printer flag and add documentation. --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 30 +++++++++++++++++++------ 2 files changed, 24 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index c76966fc..02e19531 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap ifaces + ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey 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 f2caa2c1..1fadef49 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -14,35 +14,51 @@ import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath - -> PackageKey -> SrcMap -> [Interface] + +-- | Generate hyperlinked source for given interfaces. +-- +-- Note that list of interfaces should also contain interfaces normally hidden +-- when generating documentation. Otherwise this could lead to dead links in +-- produced source. +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 + -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty pkg 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 pkg srcs) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces where srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath +-- | Generate hyperlinked source for particular interface. +ppHyperlinkedModuleSource :: FilePath -> Bool -> PackageKey -> SrcMap -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pkg srcs iface = +ppHyperlinkedModuleSource srcdir pretty pkg srcs iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path . showHtml . render' $ tokens + Just tokens -> writeFile path . html . render' $ tokens Nothing -> return () where render' = render (Just srcCssFile) (Just highlightScript) pkg srcs + html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) +-- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" +-- | Name of highlight script in output and resource directory. highlightScript :: FilePath highlightScript = "highlight.js" +-- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" -- cgit v1.2.3 From 99980dcc63d696c7912ff1f0d2faadcce169f184 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak 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/src/Haddock/Backends/Hyperlinker.hs') 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 From fcaa46b054fc3b5a5535a748d3c3283629e3eadf Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:39:57 +0200 Subject: Extract main hyperlinker types to separate module. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Ast.hs | 27 ++-------- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 40 ++------------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Types.hs | 59 ++++++++++++++++++++++ .../src/Haddock/Backends/Hyperlinker/Utils.hs | 1 + haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/Types.hs | 3 +- haddock.cabal | 5 ++ 10 files changed, 79 insertions(+), 63 deletions(-) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 11567f99..3838c3d8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -85,6 +85,7 @@ library Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f007f970..4b58190c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -3,6 +3,7 @@ module Haddock.Backends.Hyperlinker , module Haddock.Backends.Hyperlinker.Utils ) where + import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 9d5c127d..28fdc3f5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -3,12 +3,10 @@ {-# LANGUAGE RecordWildCards #-} -module Haddock.Backends.Hyperlinker.Ast - ( enrich - , RichToken(..), TokenDetails(..), rtkName - ) where +module Haddock.Backends.Hyperlinker.Ast (enrich) where -import Haddock.Backends.Hyperlinker.Parser + +import Haddock.Backends.Hyperlinker.Types import qualified GHC @@ -16,25 +14,6 @@ import Control.Applicative import Data.Data import Data.Maybe -data RichToken = RichToken - { rtkToken :: Token - , rtkDetails :: Maybe TokenDetails - } - -data TokenDetails - = RtkVar GHC.Name - | RtkType GHC.Name - | RtkBind GHC.Name - | RtkDecl GHC.Name - | RtkModule GHC.ModuleName - deriving (Eq) - -rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName -rtkName (RtkVar name) = Left name -rtkName (RtkType name) = Left name -rtkName (RtkBind name) = Left name -rtkName (RtkDecl name) = Left name -rtkName (RtkModule name) = Right name -- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index d927aa08..e206413e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,44 +1,12 @@ -module Haddock.Backends.Hyperlinker.Parser - ( parse - , Token(..), TokenType(..) - , Position(..), Span(..) - ) where +module Haddock.Backends.Hyperlinker.Parser (parse) where + import Data.Char import Data.List import Data.Maybe -data Token = Token - { tkType :: TokenType - , tkValue :: String - , tkSpan :: Span - } - -data Position = Position - { posRow :: !Int - , posCol :: !Int - } - -data Span = Span - { spStart :: Position - , spEnd :: Position - } - -data TokenType - = TkIdentifier - | TkKeyword - | TkString - | TkChar - | TkNumber - | TkOperator - | TkGlyph - | TkSpecial - | TkSpace - | TkComment - | TkCpp - | TkPragma - | TkUnknown - deriving (Show, Eq) +import Haddock.Backends.Hyperlinker.Types + -- | Turn source code string into a stream of more descriptive tokens. -- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index a4d7bc2d..add1465b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,8 +1,8 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where + import Haddock.Types -import Haddock.Backends.Hyperlinker.Parser -import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import qualified GHC diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs new file mode 100644 index 00000000..19cc5288 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -0,0 +1,59 @@ +module Haddock.Backends.Hyperlinker.Types where + + +import qualified GHC + + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkPragma + | TkUnknown + deriving (Show, Eq) + + +data RichToken = RichToken + { rtkToken :: Token + , rtkDetails :: Maybe TokenDetails + } + +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name + | RtkModule GHC.ModuleName + deriving (Eq) + + +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 9ba8446d..db2bfc76 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, ) where + import Haddock.Backends.Xhtml.Utils import GHC diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 59f7076f..0599151e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -21,6 +21,7 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index da4b3eec..90dbb4d4 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,7 +35,8 @@ import DynFlags (ExtensionFlag, Language) import OccName import Outputable import Control.Monad (ap) -import Haddock.Backends.Hyperlinker.Ast + +import Haddock.Backends.Hyperlinker.Types ----------------------------------------------------------------------------- -- * Convenient synonyms diff --git a/haddock.cabal b/haddock.cabal index 2a1caee7..8fa9f33d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,6 +104,11 @@ executable haddock Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Ast + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types + Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types Haddock.Doc -- cgit v1.2.3 From 13254609062a16e010d1c5a24e571dfe98ab6f69 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:52:13 +0200 Subject: Move source paths types to hyperlinker types module. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 ++ haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 - haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 13 +++++++++++++ haddock-api/src/Haddock/Types.hs | 9 --------- 4 files changed, 15 insertions(+), 10 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 4b58190c..248a8a54 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,11 +1,13 @@ module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Types , module Haddock.Backends.Hyperlinker.Utils ) where import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index add1465b..1065897d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,7 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where -import Haddock.Types import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index 19cc5288..ecb51a07 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -3,6 +3,8 @@ module Haddock.Backends.Hyperlinker.Types where import qualified GHC +import Data.Map (Map) + data Token = Token { tkType :: TokenType @@ -57,3 +59,14 @@ rtkName (RtkType name) = Left name rtkName (RtkBind name) = Left name rtkName (RtkDecl name) = Left name rtkName (RtkModule name) = Right name + + +-- | 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 + +type SrcMap = Map GHC.Module SrcPath diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 90dbb4d4..6dd64506 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -51,7 +51,6 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map Module SrcPath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -272,14 +271,6 @@ 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 = Documented Name Module -- cgit v1.2.3