Move sources under haddock-api/src

1 files changed, 143 insertions, 0 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
new file mode 100644
index 00000000..5e27d9b0
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -0,0 +1,143 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 Control.Applicative ((<$>))
+
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils
+import Haddock.Doc (combineDocumentation)
+
+import Text.XHtml hiding ( name, p, quote )
+import Data.Maybe (fromMaybe)
+
+import GHC
+
+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               = \m -> let (mdl,ref) = break (=='#') m
+                                         -- Accomodate for old style
+                                         -- foo\#bar anchors
+                                         mdl' = case reverse mdl of
+                                           '\\':_ -> init mdl
+                                           _ -> mdl
+                                     in ppModuleRef (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 url mLabel
+                                  else toHtml $ fromMaybe url mLabel,
+  markupAName                = \aname -> namedAnchor aname << "",
+  markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
+  markupProperty             = pre . toHtml,
+  markupExample              = examplesToHtml,
+  markupHeader               = \(Header l t) -> makeHeader l t
+  }
+  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!"
+
+
+    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"]
+
+
+-- 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 :: Qualification -> Doc DocName -> Html
+docToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual True (ppDocName 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 :: Qualification -> Doc DocName -> Html
+docToHtmlNoAnchors qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
+
+origDocToHtml :: Qualification -> Doc Name -> Html
+origDocToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual True (const $ ppName Raw)
+
+
+rdrDocToHtml :: Qualification -> Doc RdrName -> Html
+rdrDocToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual True (const ppRdrName)
+
+
+docElement :: (Html -> Html) -> Html -> Html
+docElement el content_ =
+  if isNoHtml content_
+    then el ! [theclass "doc empty"] << spaceHtml
+    else el ! [theclass "doc"] << content_
+
+
+docSection :: Qualification -> Documentation DocName -> Html
+docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
+
+
+docSection_ :: Qualification -> Doc DocName -> Html
+docSection_ qual = (docElement thediv <<) . docToHtml qual
+
+
+cleanup :: Doc a -> Doc a
+cleanup = 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 a (Doc a)
+    fmtUnParagraphLists = idMarkup {
+      markupUnorderedList = DocUnorderedList . map unParagraph,
+      markupOrderedList   = DocOrderedList   . map unParagraph
+      }