From 5bd9262466a0e71da4e84654a1906b76996e3692 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sun, 8 Aug 2021 17:19:06 +0200 Subject: coot/multiple packages (ghc-9.2) (#1418) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 137 +++++++++++++++++------ haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 7 +- haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 11 ++ 3 files changed, 116 insertions(+), 39 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index d390a95a..b7674b24 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -11,10 +11,11 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, + ppJsonIndex ) where @@ -38,12 +39,16 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder +import Data.Bifunctor ( bimap ) import Data.Char ( toUpper, isSpace ) +import Data.Either ( partitionEithers ) +import Data.Foldable ( traverse_) import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( () ) import qualified System.IO as IO +import qualified System.FilePath as FilePath import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) @@ -68,6 +73,7 @@ ppHtml :: UnitState -> Maybe String -- ^ The mathjax URL (--mathjax) -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) + -> BaseURL -- ^ The base URL (--base-url) -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) @@ -79,7 +85,7 @@ ppHtml :: UnitState ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode + maybe_base_url maybe_contents_url maybe_index_url unicode pkg qual debug withQuickjump = do let visible_ifaces = filter visible ifaces @@ -97,12 +103,12 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug - when withQuickjump $ - ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual - visible_ifaces + when withQuickjump $ + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual + visible_ifaces [] mapM_ (ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces @@ -119,16 +125,23 @@ copyHtmlBits odir libdir themes withQuickjump = do return () -headHtml :: String -> Themes -> Maybe String -> Html -headHtml docTitle themes mathjax_url = - header << +headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html +headHtml docTitle themes mathjax_url base_url = + header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url) + << [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle - , styleSheet themes - , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml + , styleSheet base_url themes + , thelink ! [ rel "stylesheet" + , thetype "text/css" + , href (withBaseURL base_url quickJumpCssFile) ] + << noHtml , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml - , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml + , script ! [ src (withBaseURL base_url haddockJsFile) + , emptyAttr "async" + , thetype "text/javascript" ] + << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf , script ! [src mjUrl, thetype "text/javascript"] << noHtml ] @@ -281,7 +294,7 @@ ppHtmlContents state odir doctitle _maybe_package | iface <- ifaces , instIsSig iface] html = - headHtml doctitle themes mathjax_url +++ + headHtml doctitle themes mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ @@ -361,6 +374,35 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = -- * Generate the index -------------------------------------------------------------------------------- +data JsonIndexEntry = JsonIndexEntry { + jieHtmlFragment :: String, + jieName :: String, + jieModule :: String, + jieLink :: String + } + deriving Show + +instance ToJSON JsonIndexEntry where + toJSON JsonIndexEntry + { jieHtmlFragment + , jieName + , jieModule + , jieLink } = + Object + [ "display_html" .= String jieHtmlFragment + , "name" .= String jieName + , "module" .= String jieModule + , "link" .= String jieLink + ] + +instance FromJSON JsonIndexEntry where + parseJSON = withObject "JsonIndexEntry" $ \v -> + JsonIndexEntry + <$> v .: "display_html" + <*> v .: "name" + <*> v .: "module" + <*> v .: "link" + ppJsonIndex :: FilePath -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) @@ -368,34 +410,50 @@ ppJsonIndex :: FilePath -> Maybe Package -> QualOption -> [Interface] + -> [FilePath] -- ^ file paths to interface files + -- (--read-interface) -> IO () -ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do createDirectoryIfMissing True odir - IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do - Builder.hPutBuilder h (encodeToBuilder modules) + (errors, installedIndexes) <- + partitionEithers + <$> traverse + (\ifaceFile -> + let indexFile = takeDirectory ifaceFile + FilePath. "doc-index.json" in + bimap (indexFile,) (map (fixLink ifaceFile)) + <$> eitherDecodeFile @[JsonIndexEntry] indexFile) + installedIfacesPaths + traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err) + errors + IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> + Builder.hPutBuilder + h (encodeToBuilder (encodeIndexes (concat installedIndexes))) where - modules :: Value - modules = Array (concatMap goInterface ifaces) - - goInterface :: Interface -> [Value] - goInterface iface = - concatMap (goExport mdl qual) (ifaceRnExportItems iface) + encodeIndexes :: [JsonIndexEntry] -> Value + encodeIndexes installedIndexes = + toJSON + (concatMap fromInterface ifaces + ++ installedIndexes) + + fromInterface :: Interface -> [JsonIndexEntry] + fromInterface iface = + mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface where aliases = ifaceModuleAliases iface qual = makeModuleQual qual_opt aliases mdl mdl = ifaceMod iface - goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] - goExport mdl qual item + mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry + mkIndex mdl qual item | Just item_html <- processExport True links_info unicode pkg qual item - = [ Object - [ "display_html" .= String (showHtmlFragment item_html) - , "name" .= String (unwords (map getOccString names)) - , "module" .= String (moduleString mdl) - , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) - ] - ] - | otherwise = [] + = Just JsonIndexEntry + { jieHtmlFragment = showHtmlFragment item_html + , jieName = unwords (map getOccString names) + , jieModule = moduleString mdl + , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names)) + } + | otherwise = Nothing where names = exportName item ++ exportSubs item @@ -413,6 +471,13 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d links_info = (maybe_source_url, maybe_wiki_url) + -- update link using relative path to output directory + fixLink :: FilePath + -> JsonIndexEntry -> JsonIndexEntry + fixLink ifaceFile jie = + jie { jieLink = makeRelative odir (takeDirectory ifaceFile) + FilePath. jieLink jie } + ppHtmlIndex :: FilePath -> String -> Maybe String @@ -441,7 +506,7 @@ ppHtmlIndex odir doctitle _maybe_package themes where indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++ + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [ @@ -541,11 +606,11 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes - -> Maybe String -> SourceURLs -> WikiURLs + -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url maybe_contents_url maybe_index_url unicode pkg qual debug iface = do let mdl = ifaceMod iface @@ -563,7 +628,7 @@ ppHtmlModule odir doctitle themes = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str_annot themes maybe_mathjax_url +++ + headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index b1d64acd..08ef747a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -17,6 +17,7 @@ module Haddock.Backends.Xhtml.Themes ( where import Haddock.Options +import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower) @@ -176,13 +177,13 @@ cssFiles :: Themes -> [String] cssFiles ts = nub $ concatMap themeFiles ts -styleSheet :: Themes -> Html -styleSheet ts = toHtml $ zipWith mkLink rels ts +styleSheet :: BaseURL -> Themes -> Html +styleSheet base_url ts = toHtml $ zipWith mkLink rels ts where rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink - ! [ href (themeHref t), rel aRel, thetype "text/css", + ! [ href (withBaseURL base_url (themeHref t)), rel aRel, thetype "text/css", XHtml.title (themeName t) ] << noHtml diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index e3fd2d5a..a68cb559 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -12,6 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types ( SourceURLs, WikiURLs, + BaseURL, + withBaseURL, LinksInfo, Splice, Unicode, @@ -20,12 +22,21 @@ module Haddock.Backends.Xhtml.Types ( import Data.Map import GHC +import qualified System.FilePath as FilePath -- the base, module and entity URLs for the source code and wiki links. type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) +-- | base url for loading js, json, css resources. The default is "." +-- +type BaseURL = Maybe String + +-- TODO: we shouldn't use 'FilePath.' +withBaseURL :: BaseURL -> String -> String +withBaseURL Nothing uri = uri +withBaseURL (Just baseUrl) uri = baseUrl FilePath. uri -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs) -- cgit v1.2.3