content: -----------------------------------------------------------------------------
  
  -----------------------------------------------------------------------------
  
  -- |
  -- 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 Data.Maybe (fromMaybe)
  import GHC
  import GHC.Types.Name
  import Text.XHtml hiding (name, p, quote)
  
  import Documentation.Haddock.Markup
  import Haddock.Backends.Xhtml.Names
  import Haddock.Backends.Xhtml.Utils
  import Haddock.Doc
    ( combineDocumentation
    , emptyMetaDoc
    , metaConcat
    , metaDocAppend
    )
  import Haddock.Types
  import Haddock.Utils
  
  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 ! [theclass "inline-code"]
      , markupUnorderedList = unordList
      , markupOrderedList = makeOrdList
      , 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"]
  
      makeOrdList :: HTML a => [(Int, a)] -> Html
      makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items
  
  -- | 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 m =
    maybe noHtml (renderMetaSince fmt currPkg) (_metaSince m)
  
  renderMetaSince :: DocMarkup id Html -> Maybe Package -> MetaSince -> Html
  renderMetaSince fmt currPkg (MetaSince{sincePackage = pkg, sinceVersion = ver}) =
    markupParagraph fmt . markupEmphasis fmt . toHtml $
      "Since: " ++ formatPkgMaybe pkg ++ formatVersion ver
    where
      formatVersion v = concat . intersperse "." $ map show v
      formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-"
      formatPkgMaybe _ = ""
  
  -- | 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 (\(index, a) -> (index, unParagraph a))
          }
  