-----------------------------------------------------------------------------
-- |
-- 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
import Name


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

    makeTable :: [TableRow Html] -> [TableRow Html] -> Html
    makeTable :: [TableRow Html] -> [TableRow Html] -> Html
makeTable [TableRow Html]
hs [TableRow Html]
bs = Html -> Html
table ([Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml ([Html]
hs' [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++ [Html]
bs'))
      where
        hs' :: [Html]
hs' | [TableRow Html] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TableRow Html]
hs   = []
            | Bool
otherwise = [Html -> Html
thead ([Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml ((TableRow Html -> Html) -> [TableRow Html] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map ((Html -> Html) -> TableRow Html -> Html
makeTableRow Html -> Html
th) [TableRow Html]
hs))]

        bs' :: [Html]
bs' = [Html -> Html
tbody ([Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml ((TableRow Html -> Html) -> [TableRow Html] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map ((Html -> Html) -> TableRow Html -> Html
makeTableRow Html -> Html
td) [TableRow Html]
bs))]

    makeTableRow :: (Html -> Html) -> TableRow Html -> Html
    makeTableRow :: (Html -> Html) -> TableRow Html -> Html
makeTableRow Html -> Html
thr (TableRow [TableCell Html]
cs) = Html -> Html
tr ([Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml ((TableCell Html -> Html) -> [TableCell Html] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map ((Html -> Html) -> TableCell Html -> Html
makeTableCell Html -> Html
thr) [TableCell Html]
cs))

    makeTableCell :: (Html -> Html) -> TableCell Html -> Html
    makeTableCell :: (Html -> Html) -> TableCell Html -> Html
makeTableCell Html -> Html
thr (TableCell Int
i Int
j Html
c) = Html -> Html
thr Html
c Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([HtmlAttr]
i' [HtmlAttr] -> [HtmlAttr] -> [HtmlAttr]
forall a. [a] -> [a] -> [a]
++ [HtmlAttr]
j')
      where
        i' :: [HtmlAttr]
i' = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then [] else [ Int -> HtmlAttr
colspan Int
i ]
        j' :: [HtmlAttr]
j' = if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then [] else [ Int -> HtmlAttr
rowspan Int
j ]

    examplesToHtml :: [Example] -> Html
examplesToHtml [Example]
l = Html -> Html
pre ([Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ (Example -> Html) -> [Example] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Example -> Html
exampleToHtml [Example]
l) Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"screen"]

    exampleToHtml :: Example -> Html
exampleToHtml (Example String
expression [String]
result) = Html
htmlExample
      where
        htmlExample :: Html
htmlExample = Html
htmlPrompt Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
htmlExpression Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ String -> Html
forall a. HTML a => a -> Html
toHtml ([String] -> String
unlines [String]
result)
        htmlPrompt :: Html
htmlPrompt = (Html -> Html
thecode (Html -> Html) -> (String -> Html) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
">>> ") Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"prompt"]
        htmlExpression :: Html
htmlExpression = (Html -> Html
strong (Html -> Html) -> (String -> Html) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
thecode (Html -> Html) -> (String -> Html) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
expression String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"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 effectivelly 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 Hack a id -> Hack a id -> Bool
(Hack a id -> Hack a id -> Bool)
-> (Hack a id -> Hack a id -> Bool) -> Eq (Hack a id)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a id. (Eq id, Eq a) => Hack a id -> Hack a id -> Bool
/= :: Hack a id -> Hack a id -> Bool
$c/= :: forall a id. (Eq id, Eq a) => Hack a id -> Hack a id -> Bool
== :: Hack a id -> Hack a id -> Bool
$c== :: forall a id. (Eq id, Eq a) => Hack a id -> Hack a id -> Bool
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 :: Int -> Maybe String -> [MetaDoc a id] -> Hack a id
toHack Int
_ Maybe String
_ [] = MetaDoc a id -> Hack a id
forall a id. MetaDoc a id -> Hack a id
UntouchedDoc MetaDoc a id
forall mod id. MetaDoc mod id
emptyMetaDoc
toHack Int
_ Maybe String
_ [MetaDoc a id
x] = MetaDoc a id -> Hack a id
forall a id. MetaDoc a id -> Hack a id
UntouchedDoc MetaDoc a id
x
toHack Int
n Maybe String
nm (MetaDoc { _doc :: forall mod id. MetaDoc mod id -> DocH mod id
_doc = DocHeader (Header Int
l (DocBold DocH a id
x)) }:[MetaDoc a id]
xs) =
  let -- Header with dropped bold
      h :: Header (DocH a id)
h = Int -> DocH a id -> Header (DocH a id)
forall id. Int -> id -> Header id
Header Int
l DocH a id
x
      -- Predicate for takeWhile, grab everything including ‘smaller’
      -- headers
      p :: MetaDoc mod id -> Bool
p (MetaDoc { _doc :: forall mod id. MetaDoc mod id -> DocH mod id
_doc = DocHeader (Header Int
l' DocH mod id
_) }) = Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
l
      p MetaDoc mod id
_ = Bool
True
      -- Stuff ‘under’ this header
      r :: [MetaDoc a id]
r = (MetaDoc a id -> Bool) -> [MetaDoc a id] -> [MetaDoc a id]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile MetaDoc a id -> Bool
forall mod id. MetaDoc mod id -> Bool
p [MetaDoc a id]
xs
      -- Everything else that didn't make it under
      r' :: [MetaDoc a id]
r' = Int -> [MetaDoc a id] -> [MetaDoc a id]
forall a. Int -> [a] -> [a]
drop ([MetaDoc a id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MetaDoc a id]
r) [MetaDoc a id]
xs
      app :: Hack a id -> [MetaDoc a id] -> Hack a id
app Hack a id
y [] = Hack a id
y
      app Hack a id
y [MetaDoc a id]
ys = Hack a id -> Hack a id -> Hack a id
forall a id. Hack a id -> Hack a id -> Hack a id
HackAppend Hack a id
y (Int -> Maybe String -> [MetaDoc a id] -> Hack a id
forall a id. Int -> Maybe String -> [MetaDoc a id] -> Hack a id
toHack (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Maybe String
nm [MetaDoc a id]
ys)
  in case [MetaDoc a id]
r of
      -- No content under this header
      [] -> Header (DocH a id)
-> MetaDoc a id -> Int -> Maybe String -> Hack a id
forall a id.
Header (DocH a id)
-> MetaDoc a id -> Int -> Maybe String -> Hack a id
CollapsingHeader Header (DocH a id)
h MetaDoc a id
forall mod id. MetaDoc mod id
emptyMetaDoc Int
n Maybe String
nm Hack a id -> [MetaDoc a id] -> Hack a id
forall a id. Hack a id -> [MetaDoc a id] -> Hack a id
`app` [MetaDoc a id]
r'
      -- We got something out, stitch it back together into one chunk
      MetaDoc a id
y:[MetaDoc a id]
ys -> Header (DocH a id)
-> MetaDoc a id -> Int -> Maybe String -> Hack a id
forall a id.
Header (DocH a id)
-> MetaDoc a id -> Int -> Maybe String -> Hack a id
CollapsingHeader Header (DocH a id)
h ((MetaDoc a id -> MetaDoc a id -> MetaDoc a id)
-> MetaDoc a id -> [MetaDoc a id] -> MetaDoc a id
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MetaDoc a id -> MetaDoc a id -> MetaDoc a id
forall mod id. MetaDoc mod id -> MetaDoc mod id -> MetaDoc mod id
metaDocAppend MetaDoc a id
y [MetaDoc a id]
ys) Int
n Maybe String
nm Hack a id -> [MetaDoc a id] -> Hack a id
forall a id. Hack a id -> [MetaDoc a id] -> Hack a id
`app` [MetaDoc a id]
r'
toHack Int
n Maybe String
nm (MetaDoc a id
x:[MetaDoc a id]
xs) = Hack a id -> Hack a id -> Hack a id
forall a id. Hack a id -> Hack a id -> Hack a id
HackAppend (MetaDoc a id -> Hack a id
forall a id. MetaDoc a id -> Hack a id
UntouchedDoc MetaDoc a id
x) (Int -> Maybe String -> [MetaDoc a id] -> Hack a id
forall a id. Int -> Maybe String -> [MetaDoc a id] -> Hack a id
toHack Int
n Maybe String
nm [MetaDoc a id]
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 a id -> [MetaDoc a id]
flatten MetaDoc { _meta :: forall mod id. MetaDoc mod id -> Meta
_meta = Meta
m, _doc :: forall mod id. MetaDoc mod id -> DocH mod id
_doc = DocAppend DocH a id
x DocH a id
y } =
  let f :: DocH mod id -> MetaDoc mod id
f DocH mod id
z = MetaDoc :: forall mod id. Meta -> DocH mod id -> MetaDoc mod id
MetaDoc { _meta :: Meta
_meta = Meta
m, _doc :: DocH mod id
_doc = DocH mod id
z }
  in MetaDoc a id -> [MetaDoc a id]
forall a id. MetaDoc a id -> [MetaDoc a id]
flatten (DocH a id -> MetaDoc a id
forall mod id. DocH mod id -> MetaDoc mod id
f DocH a id
x) [MetaDoc a id] -> [MetaDoc a id] -> [MetaDoc a id]
forall a. [a] -> [a] -> [a]
++ MetaDoc a id -> [MetaDoc a id]
forall a id. MetaDoc a id -> [MetaDoc a id]
flatten (DocH a id -> MetaDoc a id
forall mod id. DocH mod id -> MetaDoc mod id
f DocH a id
y)
flatten MetaDoc a id
x = [MetaDoc a id
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 :: DocMarkup id Html
-> Maybe String -> Hack (Wrap (ModuleName, OccName)) id -> Html
hackMarkup DocMarkup id Html
fmt' Maybe String
currPkg Hack (Wrap (ModuleName, OccName)) id
h' =
  let (Html
html, [Meta]
ms) = DocMarkup id Html
-> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta])
forall id.
DocMarkup id Html
-> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta])
hackMarkup' DocMarkup id Html
fmt' Hack (Wrap (ModuleName, OccName)) id
h'
  in Html
html Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ DocMarkup id Html -> Maybe String -> Meta -> Html
forall id. DocMarkup id Html -> Maybe String -> Meta -> Html
renderMeta DocMarkup id Html
fmt' Maybe String
currPkg ([Meta] -> Meta
metaConcat [Meta]
ms)
  where
    hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id
                -> (Html, [Meta])
    hackMarkup' :: DocMarkup id Html
-> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta])
hackMarkup' DocMarkup id Html
fmt Hack (Wrap (ModuleName, OccName)) id
h = case Hack (Wrap (ModuleName, OccName)) id
h of
      UntouchedDoc MetaDoc (Wrap (ModuleName, OccName)) id
d -> (DocMarkup id Html -> DocH (Wrap (ModuleName, OccName)) id -> Html
forall mod id a. DocMarkupH mod id a -> DocH mod id -> a
markup DocMarkup id Html
fmt (DocH (Wrap (ModuleName, OccName)) id -> Html)
-> DocH (Wrap (ModuleName, OccName)) id -> Html
forall a b. (a -> b) -> a -> b
$ MetaDoc (Wrap (ModuleName, OccName)) id
-> DocH (Wrap (ModuleName, OccName)) id
forall mod id. MetaDoc mod id -> DocH mod id
_doc MetaDoc (Wrap (ModuleName, OccName)) id
d, [MetaDoc (Wrap (ModuleName, OccName)) id -> Meta
forall mod id. MetaDoc mod id -> Meta
_meta MetaDoc (Wrap (ModuleName, OccName)) id
d])
      CollapsingHeader (Header Int
lvl DocH (Wrap (ModuleName, OccName)) id
titl) MetaDoc (Wrap (ModuleName, OccName)) id
par Int
n Maybe String
nm ->
        let id_ :: String
id_ = String -> String
makeAnchorId (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"ch:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"noid:" Maybe String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
            col' :: [HtmlAttr]
col' = String -> String -> [HtmlAttr]
collapseControl String
id_ String
"subheading"
            summary :: Html
summary = Html -> Html
thesummary (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ String -> HtmlAttr
theclass String
"hide-when-js-enabled" ] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Expand"
            instTable :: b -> Html
instTable b
contents = String -> DetailsState -> Html -> Html
collapseDetails String
id_ DetailsState
DetailsClosed (Html
summary Html -> b -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ b
contents)
            lvs :: [(Int, Html -> Html)]
lvs = [Int] -> [Html -> Html] -> [(Int, Html -> Html)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 .. ] [Html -> Html
h1, Html -> Html
h2, Html -> Html
h3, Html -> Html
h4, Html -> Html
h5, Html -> Html
h6]
            getHeader :: Html -> Html
getHeader = (Html -> Html) -> Maybe (Html -> Html) -> Html -> Html
forall a. a -> Maybe a -> a
fromMaybe Html -> Html
caption (Int -> [(Int, Html -> Html)] -> Maybe (Html -> Html)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
lvl [(Int, Html -> Html)]
lvs)
            subCaption :: Html
subCaption = Html -> Html
getHeader (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [HtmlAttr]
col' (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< DocMarkup id Html -> DocH (Wrap (ModuleName, OccName)) id -> Html
forall mod id a. DocMarkupH mod id a -> DocH mod id -> a
markup DocMarkup id Html
fmt DocH (Wrap (ModuleName, OccName)) id
titl
        in ((Html
subCaption Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++) (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
forall a. HTML a => a -> Html
instTable (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ DocMarkup id Html -> DocH (Wrap (ModuleName, OccName)) id -> Html
forall mod id a. DocMarkupH mod id a -> DocH mod id -> a
markup DocMarkup id Html
fmt (MetaDoc (Wrap (ModuleName, OccName)) id
-> DocH (Wrap (ModuleName, OccName)) id
forall mod id. MetaDoc mod id -> DocH mod id
_doc MetaDoc (Wrap (ModuleName, OccName)) id
par), [MetaDoc (Wrap (ModuleName, OccName)) id -> Meta
forall mod id. MetaDoc mod id -> Meta
_meta MetaDoc (Wrap (ModuleName, OccName)) id
par])
      HackAppend Hack (Wrap (ModuleName, OccName)) id
d Hack (Wrap (ModuleName, OccName)) id
d' -> let (Html
x, [Meta]
m) = DocMarkup id Html
-> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta])
forall id.
DocMarkup id Html
-> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta])
hackMarkup' DocMarkup id Html
fmt Hack (Wrap (ModuleName, OccName)) id
d
                             (Html
y, [Meta]
m') = DocMarkup id Html
-> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta])
forall id.
DocMarkup id Html
-> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta])
hackMarkup' DocMarkup id Html
fmt Hack (Wrap (ModuleName, OccName)) id
d'
                         in (DocMarkup id Html -> Html -> Html -> Html
forall mod id a. DocMarkupH mod id a -> a -> a -> a
markupAppend DocMarkup id Html
fmt Html
x Html
y, [Meta]
m [Meta] -> [Meta] -> [Meta]
forall a. [a] -> [a] -> [a]
++ [Meta]
m')

renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html
renderMeta :: DocMarkup id Html -> Maybe String -> Meta -> Html
renderMeta DocMarkup id Html
fmt Maybe String
currPkg (Meta { _version :: Meta -> Maybe [Int]
_version = Just [Int]
x, _package :: Meta -> Maybe String
_package = Maybe String
pkg }) =
  DocMarkup id Html -> Html -> Html
forall mod id a. DocMarkupH mod id a -> a -> a
markupParagraph DocMarkup id Html
fmt (Html -> Html) -> (String -> Html) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocMarkup id Html -> Html -> Html
forall mod id a. DocMarkupH mod id a -> a -> a
markupEmphasis DocMarkup id Html
fmt (Html -> Html) -> (String -> Html) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$
    String
"Since: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
formatPkgMaybe Maybe String
pkg String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => [a] -> String
formatVersion [Int]
x
  where
    formatVersion :: [a] -> String
formatVersion [a]
v = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
v
    formatPkgMaybe :: Maybe String -> String
formatPkgMaybe (Just String
p) | String -> Maybe String
forall a. a -> Maybe a
Just String
p Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe String
currPkg = String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-"
    formatPkgMaybe Maybe String
_ = String
""
renderMeta DocMarkup id Html
_ Maybe String
_ Meta
_ = Html
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 :: DocMarkup (Wrap id) Html
-> Maybe String -> Maybe String -> MDoc id -> Html
markupHacked DocMarkup (Wrap id) Html
fmt Maybe String
currPkg Maybe String
n = DocMarkup (Wrap id) Html
-> Maybe String
-> Hack (Wrap (ModuleName, OccName)) (Wrap id)
-> Html
forall id.
DocMarkup id Html
-> Maybe String -> Hack (Wrap (ModuleName, OccName)) id -> Html
hackMarkup DocMarkup (Wrap id) Html
fmt Maybe String
currPkg (Hack (Wrap (ModuleName, OccName)) (Wrap id) -> Html)
-> (MDoc id -> Hack (Wrap (ModuleName, OccName)) (Wrap id))
-> MDoc id
-> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Maybe String
-> [MDoc id]
-> Hack (Wrap (ModuleName, OccName)) (Wrap id)
forall a id. Int -> Maybe String -> [MetaDoc a id] -> Hack a id
toHack Int
0 Maybe String
n ([MDoc id] -> Hack (Wrap (ModuleName, OccName)) (Wrap id))
-> (MDoc id -> [MDoc id])
-> MDoc id
-> Hack (Wrap (ModuleName, OccName)) (Wrap id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDoc id -> [MDoc id]
forall a id. MetaDoc a id -> [MetaDoc a id]
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 :: Maybe String
-> Maybe String -> Qualification -> MDoc DocName -> Html
docToHtml Maybe String
n Maybe String
pkg Qualification
qual = DocMarkup (Wrap DocName) Html
-> Maybe String -> Maybe String -> MDoc DocName -> Html
forall id.
DocMarkup (Wrap id) Html
-> Maybe String -> Maybe String -> MDoc id -> Html
markupHacked DocMarkup (Wrap DocName) Html
fmt Maybe String
pkg Maybe String
n (MDoc DocName -> Html)
-> (MDoc DocName -> MDoc DocName) -> MDoc DocName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDoc DocName -> MDoc DocName
forall a. MDoc a -> MDoc a
cleanup
  where fmt :: DocMarkup (Wrap DocName) Html
fmt = Qualification
-> Bool
-> (Bool -> Wrap DocName -> Html)
-> DocMarkup (Wrap DocName) Html
forall a.
Qualification -> Bool -> (Bool -> a -> Html) -> DocMarkup a Html
parHtmlMarkup Qualification
qual Bool
True (Qualification -> Notation -> Bool -> Wrap DocName -> Html
ppWrappedDocName Qualification
qual Notation
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 :: Maybe String
-> Maybe String -> Qualification -> MDoc DocName -> Html
docToHtmlNoAnchors Maybe String
n Maybe String
pkg Qualification
qual = DocMarkup (Wrap DocName) Html
-> Maybe String -> Maybe String -> MDoc DocName -> Html
forall id.
DocMarkup (Wrap id) Html
-> Maybe String -> Maybe String -> MDoc id -> Html
markupHacked DocMarkup (Wrap DocName) Html
fmt Maybe String
pkg Maybe String
n (MDoc DocName -> Html)
-> (MDoc DocName -> MDoc DocName) -> MDoc DocName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDoc DocName -> MDoc DocName
forall a. MDoc a -> MDoc a
cleanup
  where fmt :: DocMarkup (Wrap DocName) Html
fmt = Qualification
-> Bool
-> (Bool -> Wrap DocName -> Html)
-> DocMarkup (Wrap DocName) Html
forall a.
Qualification -> Bool -> (Bool -> a -> Html) -> DocMarkup a Html
parHtmlMarkup Qualification
qual Bool
False (Qualification -> Notation -> Bool -> Wrap DocName -> Html
ppWrappedDocName Qualification
qual Notation
Raw)

origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
origDocToHtml :: Maybe String -> Qualification -> MDoc Name -> Html
origDocToHtml Maybe String
pkg Qualification
qual = DocMarkup (Wrap Name) Html
-> Maybe String -> Maybe String -> MDoc Name -> Html
forall id.
DocMarkup (Wrap id) Html
-> Maybe String -> Maybe String -> MDoc id -> Html
markupHacked DocMarkup (Wrap Name) Html
fmt Maybe String
pkg Maybe String
forall a. Maybe a
Nothing (MDoc Name -> Html)
-> (MDoc Name -> MDoc Name) -> MDoc Name -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDoc Name -> MDoc Name
forall a. MDoc a -> MDoc a
cleanup
  where fmt :: DocMarkup (Wrap Name) Html
fmt = Qualification
-> Bool
-> (Bool -> Wrap Name -> Html)
-> DocMarkup (Wrap Name) Html
forall a.
Qualification -> Bool -> (Bool -> a -> Html) -> DocMarkup a Html
parHtmlMarkup Qualification
qual Bool
True ((Wrap Name -> Html) -> Bool -> Wrap Name -> Html
forall a b. a -> b -> a
const (Notation -> Wrap Name -> Html
ppWrappedName Notation
Raw))


rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
rdrDocToHtml :: Maybe String -> Qualification -> MDoc RdrName -> Html
rdrDocToHtml Maybe String
pkg Qualification
qual = DocMarkup (Wrap RdrName) Html
-> Maybe String -> Maybe String -> MDoc RdrName -> Html
forall id.
DocMarkup (Wrap id) Html
-> Maybe String -> Maybe String -> MDoc id -> Html
markupHacked DocMarkup (Wrap RdrName) Html
fmt Maybe String
pkg Maybe String
forall a. Maybe a
Nothing (MDoc RdrName -> Html)
-> (MDoc RdrName -> MDoc RdrName) -> MDoc RdrName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDoc RdrName -> MDoc RdrName
forall a. MDoc a -> MDoc a
cleanup
  where fmt :: DocMarkup (Wrap RdrName) Html
fmt = Qualification
-> Bool
-> (Bool -> Wrap RdrName -> Html)
-> DocMarkup (Wrap RdrName) Html
forall a.
Qualification -> Bool -> (Bool -> a -> Html) -> DocMarkup a Html
parHtmlMarkup Qualification
qual Bool
True ((Wrap RdrName -> Html) -> Bool -> Wrap RdrName -> Html
forall a b. a -> b -> a
const (RdrName -> Html
ppRdrName (RdrName -> Html)
-> (Wrap RdrName -> RdrName) -> Wrap RdrName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wrap RdrName -> RdrName
forall n. Wrap n -> n
unwrap))


docElement :: (Html -> Html) -> Html -> Html
docElement :: (Html -> Html) -> Html -> Html
docElement Html -> Html
el Html
content_ =
  if Html -> Bool
isNoHtml Html
content_
    then Html -> Html
el (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"doc empty"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
spaceHtml
    else Html -> Html
el (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"doc"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
content_


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


docSection_ :: Maybe Name    -- ^ Name of the thing this doc is for
            -> Maybe Package -- ^ Current package
            -> Qualification -> MDoc DocName -> Html
docSection_ :: Maybe Name -> Maybe String -> Qualification -> MDoc DocName -> Html
docSection_ Maybe Name
n Maybe String
pkg Qualification
qual =
  ((Html -> Html) -> Html -> Html
docElement Html -> Html
thediv (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<) (Html -> Html) -> (MDoc DocName -> Html) -> MDoc DocName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String
-> Maybe String -> Qualification -> MDoc DocName -> Html
docToHtml (Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Maybe Name -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
n) Maybe String
pkg Qualification
qual


cleanup :: MDoc a -> MDoc a
cleanup :: MDoc a -> MDoc a
cleanup = (DocH (Wrap (ModuleName, OccName)) (Wrap a)
 -> DocH (Wrap (ModuleName, OccName)) (Wrap a))
-> MDoc a -> MDoc a
forall a b c d.
(DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
overDoc (DocMarkupH
  (Wrap (ModuleName, OccName))
  (Wrap a)
  (DocH (Wrap (ModuleName, OccName)) (Wrap a))
-> DocH (Wrap (ModuleName, OccName)) (Wrap a)
-> DocH (Wrap (ModuleName, OccName)) (Wrap a)
forall mod id a. DocMarkupH mod id a -> DocH mod id -> a
markup DocMarkupH
  (Wrap (ModuleName, OccName))
  (Wrap a)
  (DocH (Wrap (ModuleName, OccName)) (Wrap a))
forall a. DocMarkup (Wrap a) (Doc a)
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 :: Doc a -> Doc a
unParagraph (DocParagraph Doc a
d) = Doc a
d
    unParagraph Doc a
doc              = Doc a
doc

    fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
    fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
fmtUnParagraphLists = DocMarkup (Wrap a) (Doc a)
forall mod id. DocMarkupH mod id (DocH mod id)
idMarkup {
      markupUnorderedList :: [Doc a] -> Doc a
markupUnorderedList = [Doc a] -> Doc a
forall mod id. [DocH mod id] -> DocH mod id
DocUnorderedList ([Doc a] -> Doc a) -> ([Doc a] -> [Doc a]) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc a -> Doc a) -> [Doc a] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Doc a -> Doc a
forall a. Doc a -> Doc a
unParagraph,
      markupOrderedList :: [Doc a] -> Doc a
markupOrderedList   = [Doc a] -> Doc a
forall mod id. [DocH mod id] -> DocH mod id
DocOrderedList   ([Doc a] -> Doc a) -> ([Doc a] -> [Doc a]) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc a -> Doc a) -> [Doc a] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Doc a -> Doc a
forall a. Doc a -> Doc a
unParagraph
      }