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') 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