path: root/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html.DocMarkup
-- Copyright   :  (c) Simon Marlow   2003-2006,
--                    David Waern    2006-2009,
--                    Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.DocMarkup (
  docToHtml,
  rdrDocToHtml,
  origDocToHtml,
  docToHtmlNoAnchors,

  docElement, docSection, docSection_,
) where

import Data.List (intersperse)
import Documentation.Haddock.Markup
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils
import Haddock.Doc (combineDocumentation, emptyMetaDoc,
                    metaDocAppend, metaConcat)

import Text.XHtml hiding ( name, p, quote )
import Data.Maybe (fromMaybe)

import GHC hiding (anchor)
import GHC.Types.Name


parHtmlMarkup :: Qualification -> Bool
              -> (Bool -> a -> Html) -> DocMarkup a Html
parHtmlMarkup qual insertAnchors ppId = Markup {
  markupEmpty                = noHtml,
  markupString               = toHtml,
  markupParagraph            = paragraph,
  markupAppend               = (+++),
  markupIdentifier           = thecode . ppId insertAnchors,
  markupIdentifierUnchecked  = thecode . ppUncheckedLink qual,
  markupModule               = \(ModLink m lbl) ->
                                 let (mdl,ref) = break (=='#') m
                                       -- Accommodate for old style
                                       -- foo\#bar anchors
                                     mdl' = case reverse mdl of
                                              '\\':_ -> init mdl
                                              _ -> mdl
                                 in ppModuleRef lbl (mkModuleName mdl') ref,
  markupWarning              = thediv ! [theclass "warning"],
  markupEmphasis             = emphasize,
  markupBold                 = strong,
  markupMonospaced           = thecode,
  markupUnorderedList        = unordList,
  markupOrderedList          = ordList,
  markupDefList              = defList,
  markupCodeBlock            = pre,
  markupHyperlink            = \(Hyperlink url mLabel)
                               -> if insertAnchors
                                  then anchor ! [href url]
                                       << fromMaybe (toHtml url) mLabel
                                  else fromMaybe (toHtml url) mLabel,
  markupAName                = \aname
                               -> if insertAnchors
                                  then namedAnchor aname << ""
                                  else noHtml,
  markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
  markupMathInline           = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)"),
  markupMathDisplay          = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]"),
  markupProperty             = pre . toHtml,
  markupExample              = examplesToHtml,
  markupHeader               = \(Header l t) -> makeHeader l t,
  markupTable                = \(Table h r) -> makeTable h r
  }
  where
    makeHeader :: Int -> Html -> Html
    makeHeader 1 mkup = h1 mkup
    makeHeader 2 mkup = h2 mkup
    makeHeader 3 mkup = h3 mkup
    makeHeader 4 mkup = h4 mkup
    makeHeader 5 mkup = h5 mkup
    makeHeader 6 mkup = h6 mkup
    makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"

    makeTable :: [TableRow Html] -> [TableRow Html] -> Html
    makeTable hs bs = table (concatHtml (hs' ++ bs'))
      where
        hs' | null hs   = []
            | otherwise = [thead (concatHtml (map (makeTableRow th) hs))]

        bs' = [tbody (concatHtml (map (makeTableRow td) bs))]

    makeTableRow :: (Html -> Html) -> TableRow Html -> Html
    makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs))

    makeTableCell :: (Html -> Html) -> TableCell Html -> Html
    makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j')
      where
        i' = if i == 1 then [] else [ colspan i ]
        j' = if j == 1 then [] else [ rowspan j ]

    examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]

    exampleToHtml (Example expression result) = htmlExample
      where
        htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
        htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
        htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]

-- | We use this intermediate type to transform the input 'Doc' tree
-- in an arbitrary way before rendering, such as grouping some
-- elements. This is effectively a hack to prevent the 'Doc' type
-- from changing if it is possible to recover the layout information
-- we won't need after the fact.
data Hack a id =
  UntouchedDoc (MetaDoc a id)
  | CollapsingHeader (Header (DocH a id)) (MetaDoc a id) Int (Maybe String)
  | HackAppend (Hack a id) (Hack a id)
  deriving Eq

-- | Group things under bold 'DocHeader's together.
toHack :: Int -- ^ Counter for header IDs which serves to assign
              -- unique identifiers within the comment scope
       -> Maybe String
       -- ^ It is not enough to have unique identifier within the
       -- scope of the comment: if two different comments have the
       -- same ID for headers, the collapse/expand behaviour will act
       -- on them both. This serves to make each header a little bit
       -- more unique. As we can't export things with the same names,
       -- this should work more or less fine: it is in fact the
       -- implicit assumption the collapse/expand mechanism makes for
       -- things like ‘Instances’ boxes.
       -> [MetaDoc a id] -> Hack a id
toHack _ _ [] = UntouchedDoc emptyMetaDoc
toHack _ _ [x] = UntouchedDoc x
toHack n nm (MetaDoc { _doc = DocHeader (Header l (DocBold x)) }:xs) =
  let -- Header with dropped bold
      h = Header l x
      -- Predicate for takeWhile, grab everything including ‘smaller’
      -- headers
      p (MetaDoc { _doc = DocHeader (Header l' _) }) = l' > l
      p _ = True
      -- Stuff ‘under’ this header
      r = takeWhile p xs
      -- Everything else that didn't make it under
      r' = drop (length r) xs
      app y [] = y
      app y ys = HackAppend y (toHack (n + 1) nm ys)
  in case r of
      -- No content under this header
      [] -> CollapsingHeader h emptyMetaDoc n nm `app` r'
      -- We got something out, stitch it back together into one chunk
      y:ys -> CollapsingHeader h (foldl metaDocAppend y ys) n nm `app` r'
toHack n nm (x:xs) = HackAppend (UntouchedDoc x) (toHack n nm xs)

-- | Remove ‘top-level’ 'DocAppend's turning them into a flat list.
-- This lends itself much better to processing things in order user
-- might look at them, such as in 'toHack'.
flatten :: MetaDoc a id -> [MetaDoc a id]
flatten MetaDoc { _meta = m, _doc = DocAppend x y } =
  let f z = MetaDoc { _meta = m, _doc = z }
  in flatten (f x) ++ flatten (f y)
flatten x = [x]

-- | Generate the markup needed for collapse to happen. For
-- 'UntouchedDoc' and 'HackAppend' we do nothing more but
-- extract/append the underlying 'Doc' and convert it to 'Html'. For
-- 'CollapsingHeader', we attach extra info to the generated 'Html'
-- that allows us to expand/collapse the content.
hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html
hackMarkup fmt' currPkg h' =
  let (html, ms) = hackMarkup' fmt' h'
  in html +++ renderMeta fmt' currPkg (metaConcat ms)
  where
    hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id
                -> (Html, [Meta])
    hackMarkup' fmt h = case h of
      UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
      CollapsingHeader (Header lvl titl) par n nm ->
        let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n
            col' = collapseControl id_ "subheading"
            summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand"
            instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents)
            lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]
            getHeader = fromMaybe caption (lookup lvl lvs)
            subCaption = getHeader ! col' << markup fmt titl
        in ((subCaption +++) . instTable $ markup fmt (_doc par), [_meta par])
      HackAppend d d' -> let (x, m) = hackMarkup' fmt d
                             (y, m') = hackMarkup' fmt d'
                         in (markupAppend fmt x y, m ++ m')

renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html
renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) =
  markupParagraph fmt . markupEmphasis fmt . toHtml $
    "Since: " ++ formatPkgMaybe pkg ++ formatVersion x
  where
    formatVersion v = concat . intersperse "." $ map show v
    formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-"
    formatPkgMaybe _ = ""
renderMeta _ _ _ = noHtml

-- | Goes through 'hackMarkup' to generate the 'Html' rather than
-- skipping straight to 'markup': this allows us to employ XHtml
-- specific hacks to the tree first.
markupHacked :: DocMarkup (Wrap id) Html
             -> Maybe Package      -- this package
             -> Maybe String
             -> MDoc id
             -> Html
markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten

-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- ugly extra whitespace with some browsers).  FIXME: Does this still apply?
docToHtml :: Maybe String  -- ^ Name of the thing this doc is for. See
                           -- comments on 'toHack' for details.
          -> Maybe Package -- ^ Current package
          -> Qualification -> MDoc DocName -> Html
docToHtml n pkg qual = markupHacked fmt pkg n . cleanup
  where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw)

-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
-- in links. This is used to generate the Contents box elements.
docToHtmlNoAnchors :: Maybe String  -- ^ See 'toHack'
                   -> Maybe Package -- ^ Current package
                   -> Qualification -> MDoc DocName -> Html
docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
  where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw)

origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
  where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw))


rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
  where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap))


docElement :: (Html -> Html) -> Html -> Html
docElement el content_ =
  if isNoHtml content_
    then el ! [theclass "doc empty"] << spaceHtml
    else el ! [theclass "doc"] << content_


docSection :: Maybe Name -- ^ Name of the thing this doc is for
           -> Maybe Package -- ^ Current package
           -> Qualification -> Documentation DocName -> Html
docSection n pkg qual =
  maybe noHtml (docSection_ n pkg qual) . combineDocumentation


docSection_ :: Maybe Name    -- ^ Name of the thing this doc is for
            -> Maybe Package -- ^ Current package
            -> Qualification -> MDoc DocName -> Html
docSection_ n pkg qual =
  (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual


cleanup :: MDoc a -> MDoc a
cleanup = overDoc (markup fmtUnParagraphLists)
  where
    -- If there is a single paragraph, then surrounding it with <P>..</P>
    -- can add too much whitespace in some browsers (eg. IE).  However if
    -- we have multiple paragraphs, then we want the extra whitespace to
    -- separate them.  So we catch the single paragraph case and transform it
    -- here. We don't do this in code blocks as it eliminates line breaks.
    unParagraph :: Doc a -> Doc a
    unParagraph (DocParagraph d) = d
    unParagraph doc              = doc

    fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
    fmtUnParagraphLists = idMarkup {
      markupUnorderedList = DocUnorderedList . map unParagraph,
      markupOrderedList   = DocOrderedList   . map unParagraph
      }