diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Meta.hs | 22 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 76 |
2 files changed, 87 insertions, 11 deletions
diff --git a/haddock-api/src/Haddock/Backends/Meta.hs b/haddock-api/src/Haddock/Backends/Meta.hs new file mode 100644 index 00000000..c62c1ae8 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Meta.hs @@ -0,0 +1,22 @@ +module Haddock.Backends.Meta where + +import Haddock.Utils.Json +import Haddock.Version + +import Data.ByteString.Builder (hPutBuilder) +import System.FilePath ((</>)) +import System.IO (withFile, IOMode (WriteMode)) + +-- | Writes a json encoded file containing additional +-- information about the generated documentation. This +-- is useful for external tools (e.g. hackage). +writeHaddockMeta :: FilePath -> IO () +writeHaddockMeta odir = do + let + meta_json :: Value + meta_json = object [ + "haddock_version" .= String projectVersion + ] + + withFile (odir </> "meta.json") WriteMode $ \h -> + hPutBuilder h (encodeToBuilder meta_json)
\ No newline at end of file diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 7fbf9bb4..1205e57c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -11,7 +11,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, NamedFieldPuns #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, @@ -31,6 +31,7 @@ import Haddock.ModuleTree import Haddock.Types import Haddock.Version import Haddock.Utils +import Haddock.Utils.Json import Text.XHtml hiding ( name, title, p, quote ) import Haddock.GhcUtils @@ -88,10 +89,12 @@ ppHtml dflags doctitle maybe_package ifaces odir prologue False -- we don't want to display the packages in a single-package contents prologue debug (makeContentsQual qual) - when (isNothing maybe_index_url) $ + when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) debug + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual + visible_ifaces mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url @@ -105,7 +108,9 @@ copyHtmlBits odir libdir themes = do copyCssFile f = copyFile f (combine odir (takeFileName f)) copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) - copyLibFile jsFile + copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) + copyLibFile haddockJsFile + copyLibFile jsQuickJumpFile return () @@ -115,13 +120,9 @@ headHtml docTitle themes mathjax_url = meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle, styleSheet themes, - script ! [src jsFile, thetype "text/javascript"] << noHtml, - script ! [src mjUrl, thetype "text/javascript"] << noHtml, - script ! [thetype "text/javascript"] - -- NB: Within XHTML, the content of script tags needs to be - -- a <![CDATA[ section. - << primHtml - "//<![CDATA[\nwindow.onload = function () {pageLoad();};\n//]]>\n" + thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml, + script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml, + script ! [src mjUrl, thetype "text/javascript"] << noHtml ] where mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url @@ -188,7 +189,6 @@ bodyHtml doctitle iface ) ] - moduleInfo :: Interface -> Html moduleInfo iface = let @@ -341,6 +341,60 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = -- * Generate the index -------------------------------------------------------------------------------- +ppJsonIndex :: FilePath + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Bool + -> QualOption + -> [Interface] + -> IO () +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do + createDirectoryIfMissing True odir + writeFile (joinPath [odir, indexJsonFile]) + (encodeToString modules) + + where + modules :: Value + modules = Array (concatMap goInterface ifaces) + + goInterface :: Interface -> [Value] + goInterface iface = + concatMap (goExport mdl qual) (ifaceRnExportItems iface) + where + aliases = ifaceModuleAliases iface + qual = makeModuleQual qual_opt aliases mdl + mdl = ifaceMod iface + + goExport :: Module -> Qualification -> ExportItem DocName -> [Value] + goExport mdl qual item + | Just item_html <- processExport True links_info unicode qual item + = [ Object + [ "display_html" .= String (showHtmlFragment item_html) + , "name" .= String (intercalate " " (map nameString names)) + , "module" .= String (moduleString mdl) + , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) + ] + ] + | otherwise = [] + where + names = exportName item ++ exportSubs item + + exportSubs :: ExportItem DocName -> [DocName] + exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs + exportSubs _ = [] + + exportName :: ExportItem DocName -> [DocName] + exportName ExportDecl { expItemDecl } = getMainDeclBinder $ unLoc expItemDecl + exportName ExportNoDecl { expItemName } = [expItemName] + exportName _ = [] + + nameString :: NamedThing name => name -> String + nameString = occNameString . nameOccName . getName + + nameLink :: NamedThing name => Module -> name -> String + nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName + + links_info = (maybe_source_url, maybe_wiki_url) ppHtmlIndex :: FilePath -> String |