module Haddock.Backends.Xhtml (
ppHtml, copyHtmlBits,
ppHtmlIndex, ppHtmlContents,
) where
import Prelude hiding (div)
import Haddock.Backends.Xhtml.Decl
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Layout
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Themes
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.ModuleTree
import Haddock.Types
import Haddock.Version
import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
import Haddock.GhcUtils
import Control.Monad ( when, unless )
import Control.Monad.Instances ( )
import Data.Char ( toUpper )
import Data.List ( sortBy, groupBy, intercalate )
import Data.Maybe
import System.FilePath hiding ( (</>) )
import System.Directory
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import Data.Function
import Data.Ord ( comparing )
import GHC hiding ( NoLink, moduleInfo )
import Name
import Module
ppHtml :: String
-> Maybe String
-> [Interface]
-> FilePath
-> Maybe (Doc GHC.RdrName)
-> Themes
-> SourceURLs
-> WikiURLs
-> Maybe String
-> Maybe String
-> Bool
-> Qualification
-> Bool
-> IO ()
ppHtml doctitle maybe_package ifaces odir prologue
themes maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode
qual debug = do
let
visible_ifaces = filter visible ifaces
visible i = OptHide `notElem` ifaceOptions i
when (isNothing maybe_contents_url) $
ppHtmlContents odir doctitle maybe_package
themes maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces)
False
prologue
debug
when (isNothing maybe_index_url) $
ppHtmlIndex odir doctitle maybe_package
themes maybe_contents_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces) debug
mapM_ (ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
copyHtmlBits odir libdir themes = do
let
libhtmldir = joinPath [libdir, "html"]
copyCssFile f = copyFile f (combine odir (takeFileName f))
copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
mapM_ copyCssFile (cssFiles themes)
mapM_ copyLibFile [ jsFile, framesFile ]
headHtml :: String -> Maybe String -> Themes -> Html
headHtml docTitle miniPage themes =
header << [
meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
thetitle << docTitle,
styleSheet themes,
script ! [src jsFile, thetype "text/javascript"] << noHtml,
script ! [thetype "text/javascript"]
<< primHtml (
"//<![CDATA[\nwindow.onload = function () {pageLoad();"
++ setSynopsis ++ "};\n//]]>\n")
]
where
setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
srcButton (Just src_base_url, _, _) Nothing =
Just (anchor ! [href src_base_url] << "Source")
srcButton (_, Just src_module_url, _) (Just iface) =
let url = spliceURL (Just $ ifaceOrigFilename iface)
(Just $ ifaceMod iface) Nothing Nothing src_module_url
in Just (anchor ! [href url] << "Source")
srcButton _ _ =
Nothing
wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
wikiButton (Just wiki_base_url, _, _) Nothing =
Just (anchor ! [href wiki_base_url] << "User Comments")
wikiButton (_, Just wiki_module_url, _) (Just mdl) =
let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
in Just (anchor ! [href url] << "User Comments")
wikiButton _ _ =
Nothing
contentsButton :: Maybe String -> Maybe Html
contentsButton maybe_contents_url
= Just (anchor ! [href url] << "Contents")
where url = fromMaybe contentsHtmlFile maybe_contents_url
indexButton :: Maybe String -> Maybe Html
indexButton maybe_index_url
= Just (anchor ! [href url] << "Index")
where url = fromMaybe indexHtmlFile maybe_index_url
bodyHtml :: String -> Maybe Interface
-> SourceURLs -> WikiURLs
-> Maybe String -> Maybe String
-> Html -> Html
bodyHtml doctitle iface
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url
pageContent =
body << [
divPackageHeader << [
unordList (catMaybes [
srcButton maybe_source_url iface,
wikiButton maybe_wiki_url (ifaceMod `fmap` iface),
contentsButton maybe_contents_url,
indexButton maybe_index_url])
! [theclass "links", identifier "page-menu"],
nonEmpty sectionName << doctitle
],
divContent << pageContent,
divFooter << paragraph << (
"Produced by " +++
(anchor ! [href projectUrl] << toHtml projectName) +++
(" version " ++ projectVersion)
)
]
moduleInfo :: Interface -> Html
moduleInfo iface =
let
info = ifaceInfo iface
doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable
doOneEntry (fieldName, field) =
field info >>= \a -> return (th << fieldName <-> td << a)
entries :: [HtmlTable]
entries = mapMaybe doOneEntry [
("Portability",hmi_portability),
("Stability",hmi_stability),
("Maintainer",hmi_maintainer)
]
in
case entries of
[] -> noHtml
_ -> table ! [theclass "info"] << aboves entries
ppHtmlContents
:: FilePath
-> String
-> Maybe String
-> Themes
-> Maybe String
-> SourceURLs
-> WikiURLs
-> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
-> Bool
-> IO ()
ppHtmlContents odir doctitle _maybe_package
themes maybe_index_url
maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug = do
let tree = mkModuleTree showPkgs
[(instMod iface, toInstalledDescription iface) | iface <- ifaces]
html =
headHtml doctitle Nothing themes +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
ppPrologue doctitle prologue,
ppModuleTree tree
]
createDirectoryIfMissing True odir
writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
ppHtmlContentsFrame odir doctitle themes ifaces debug
ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html
ppPrologue _ Nothing = noHtml
ppPrologue title (Just doc) =
docElement divDescription << (h1 << title +++ rdrDocToHtml doc)
ppModuleTree :: [ModuleTree] -> Html
ppModuleTree ts =
divModuleList << (sectionName << "Modules" +++ mkNodeList [] "n" ts)
mkNodeList :: [String] -> String -> [ModuleTree] -> Html
mkNodeList ss p ts = case ts of
[] -> noHtml
_ -> unordList (zipWith (mkNode ss) ps ts)
where
ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
mkNode :: [String] -> String -> ModuleTree -> Html
mkNode ss p (Node s leaf pkg short ts) =
htmlModule +++ shortDescr +++ htmlPkg +++ subtree
where
modAttrs = case (ts, leaf) of
(_:_, False) -> collapseControl p True "module"
(_, _ ) -> [theclass "module"]
cBtn = case (ts, leaf) of
(_:_, True) -> thespan ! collapseControl p True "" << spaceHtml
(_, _ ) -> noHtml
htmlModule = thespan ! modAttrs << (cBtn +++
if leaf
then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
(mkModuleName mdl))
else toHtml s
)
mdl = intercalate "." (reverse (s:ss))
shortDescr = maybe noHtml origDocToHtml short
htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
subtree = mkNodeList (s:ss) p ts ! collapseSection p True ""
flatModuleTree :: [InstalledInterface] -> [Html]
flatModuleTree ifaces =
map (uncurry ppModule' . head)
. groupBy ((==) `on` fst)
. sortBy (comparing fst)
$ mods
where
mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
ppModule' txt mdl =
anchor ! [href (moduleHtmlFile mdl), target mainFrameName]
<< toHtml txt
ppHtmlContentsFrame :: FilePath -> String -> Themes
-> [InstalledInterface] -> Bool -> IO ()
ppHtmlContentsFrame odir doctitle themes ifaces debug = do
let mods = flatModuleTree ifaces
html =
headHtml doctitle Nothing themes +++
miniBody << divModuleList <<
(sectionName << "Modules" +++
ulist << [ li ! [theclass "module"] << m | m <- mods ])
createDirectoryIfMissing True odir
writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html)
ppHtmlIndex :: FilePath
-> String
-> Maybe String
-> Themes
-> Maybe String
-> SourceURLs
-> WikiURLs
-> [InstalledInterface]
-> Bool
-> IO ()
ppHtmlIndex odir doctitle _maybe_package themes
maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
let html = indexPage split_indices Nothing
(if split_indices then [] else index)
createDirectoryIfMissing True odir
when split_indices $ do
mapM_ (do_sub_index index) initialChars
let mergedhtml = indexPage False Nothing index
writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)
where
indexPage showLetters ch items =
headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
maybe_contents_url Nothing << [
if showLetters then indexInitialLetterLinks else noHtml,
if null items then noHtml else
divIndex << [sectionName << indexName ch, buildIndex items]
]
indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
merged_name = "All"
buildIndex items = table << aboves (map indexElt items)
split_indices = length index > 150
indexInitialLetterLinks =
divAlphabet <<
unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
[ [c] | c <- initialChars
, any ((==c) . toUpper . head . fst) index ] ++
[merged_name])
initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
do_sub_index this_ix c
= unless (null index_part) $
writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
index :: [(String, Map GHC.Name [(Module,Bool)])]
index = sortBy cmp (Map.toAscList full_index)
where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2
full_index :: Map String (Map GHC.Name [(Module,Bool)])
full_index = Map.fromListWith (flip (Map.unionWith (++)))
(concatMap getIfaceIndex ifaces)
getIfaceIndex iface =
[ (getOccString name
, Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])])
| name <- instExports iface ]
where mdl = instMod iface
indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
indexElt (str, entities) =
case Map.toAscList entities of
[(nm,entries)] ->
td ! [ theclass "src" ] << toHtml str <->
indexLinks nm entries
many_entities ->
td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
aboves (map doAnnotatedEntity (zip [1..] many_entities))
doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
doAnnotatedEntity (j,(nm,entries))
= td ! [ theclass "alt" ] <<
toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
indexLinks nm entries
ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
| isDataOcc n = toHtml "Data Constructor"
| otherwise = toHtml "Function"
indexLinks nm entries =
td ! [ theclass "module" ] <<
hsep (punctuate comma
[ if visible then
linkId mdl (Just nm) << toHtml (moduleString mdl)
else
toHtml (moduleString mdl)
| (mdl, visible) <- entries ])
ppHtmlModule
:: FilePath -> String -> Themes
-> SourceURLs -> WikiURLs
-> Maybe String -> Maybe String -> Bool -> Qualification
-> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode qual debug iface = do
let
mdl = ifaceMod iface
mdl_str = moduleString mdl
real_qual = case qual of
LocalQual Nothing -> LocalQual (Just mdl)
RelativeQual Nothing -> RelativeQual (Just mdl)
_ -> qual
html =
headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
]
createDirectoryIfMissing True odir
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
-> Interface -> Bool -> Qualification -> Bool -> IO ()
ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do
let mdl = ifaceMod iface
html =
headHtml (moduleString mdl) Nothing themes +++
miniBody <<
(divModuleHeader << sectionName << moduleString mdl +++
miniSynopsis mdl iface unicode qual)
createDirectoryIfMissing True odir
writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
= ppModuleContents qual exports +++
description +++
synopsis +++
divInterface (maybe_doc_hdr +++ bdy)
where
exports = numberSectionHeadings (ifaceRnExportItems iface)
has_doc (ExportDecl _ doc _ _) = isJust (fst doc)
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
no_doc_at_all = not (any has_doc exports)
description
= case ifaceRnDoc iface of
Nothing -> noHtml
Just doc -> divDescription $
sectionName << "Description" +++ docSection qual doc
synopsis
| no_doc_at_all = noHtml
| otherwise
= divSynposis $
paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++
shortDeclList (
mapMaybe (processExport True linksInfo unicode qual) exports
) ! (collapseSection "syn" False "" ++ collapseToggle "syn")
maybe_doc_hdr
= case exports of
[] -> noHtml
ExportGroup _ _ _ : _ -> noHtml
_ -> h1 << "Documentation"
bdy =
foldr (+++) noHtml $
mapMaybe (processExport False linksInfo unicode qual) exports
linksInfo = (maybe_source_url, maybe_wiki_url)
miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
miniSynopsis mdl iface unicode qual =
divInterface << mapMaybe (processForMiniSynopsis mdl unicode qual) exports
where
exports = numberSectionHeadings (ifaceRnExportItems iface)
processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
-> Maybe Html
processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) =
((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
(TyFamily{}) -> Just $ ppTyFamHeader True False d unicode
(TyData{tcdTyPats = ps})
| Nothing <- ps -> Just $ keyword "data" <+> b
| Just _ <- ps -> Just $ keyword "data" <+> keyword "instance" <+> b
(TySynonym{tcdTyPats = ps})
| Nothing <- ps -> Just $ keyword "type" <+> b
| Just _ <- ps -> Just $ keyword "type" <+> keyword "instance" <+> b
(ClassDecl {}) -> Just $ keyword "class" <+> b
_ -> Nothing
SigD (TypeSig (L _ n) (L _ _)) ->
Just $ ppNameMini mdl (nameOccName . getName $ n)
_ -> Nothing
processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
Just $ groupTag lvl << docToHtml qual txt
processForMiniSynopsis _ _ _ _ = Nothing
ppNameMini :: Module -> OccName -> Html
ppNameMini mdl nm =
anchor ! [ href (moduleNameUrl mdl nm)
, target mainFrameName ]
<< ppBinder' nm
ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
ppTyClBinderWithVarsMini mdl decl =
let n = unLoc $ tcdLName decl
ns = tyvarNames $ tcdTyVars decl
in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName
ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
ppModuleContents qual exports
| null sections = noHtml
| otherwise = contentsDiv
where
contentsDiv = divTableOfContents << (
sectionName << "Contents" +++
unordList sections)
(sections, _leftovers) = process 0 exports
process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
process _ [] = ([], [])
process n items@(ExportGroup lev id0 doc : rest)
| lev <= n = ( [], items )
| otherwise = ( html:secs, rest2 )
where
html = linkedAnchor (groupId id0) << docToHtml qual doc +++ mk_subsections ssecs
(ssecs, rest1) = process lev rest
(secs, rest2) = process n rest1
process n (_ : rest) = process n rest
mk_subsections [] = noHtml
mk_subsections ss = unordList ss
numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
numberSectionHeadings exports = go 1 exports
where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
go _ [] = []
go n (ExportGroup lev _ doc : es)
= ExportGroup lev (show n) doc : go (n+1) es
go n (other:es)
= other : go n es
processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocName -> Maybe Html
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
processExport summary links unicode qual (ExportDecl decl doc subdocs insts)
= processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual y
processExport summary _ _ qual (ExportNoDecl y subs)
= processDeclOneLiner summary $
ppDocName qual y +++ parenList (map (ppDocName qual) subs)
processExport summary _ _ qual (ExportDoc doc)
= nothingIf summary $ docSection qual doc
processExport summary _ _ _ (ExportModule mdl)
= processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
nothingIf :: Bool -> a -> Maybe a
nothingIf True _ = Nothing
nothingIf False a = Just a
processDecl :: Bool -> Html -> Maybe Html
processDecl True = Just
processDecl False = Just . divTopDecl
processDeclOneLiner :: Bool -> Html -> Maybe Html
processDeclOneLiner True = Just
processDeclOneLiner False = Just . divTopDecl . declElem
groupHeading :: Int -> String -> Html -> Html
groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]
groupTag :: Int -> Html -> Html
groupTag lev
| lev == 1 = h1
| lev == 2 = h2
| lev == 3 = h3
| otherwise = h4