-- stolen from Haddock's HsSyn.lhs and HaddockHtml.hs
module Distribution.Server.Pages.Package.HaddockHtml where
import Data.Char (isSpace)
import Text.XHtml.Strict hiding (p)
import Network.URI (escapeURIString, isUnreserved)
data GenDoc id
= DocEmpty
| DocAppend (GenDoc id) (GenDoc id)
| DocString String
| DocParagraph (GenDoc id)
| DocIdentifier id
| DocModule String
| DocEmphasis (GenDoc id)
| DocMonospaced (GenDoc id)
| DocUnorderedList [GenDoc id]
| DocOrderedList [GenDoc id]
| DocDefList [(GenDoc id, GenDoc id)]
| DocCodeBlock (GenDoc id)
| DocURL String
| DocPic String
| DocAName String
deriving (Eq, Show)
type Doc = GenDoc String
-- | DocMarkup is a set of instructions for marking up documentation.
-- In fact, it's really just a mapping from 'GenDoc' to some other
-- type [a], where [a] is usually the type of the output (HTML, say).
data DocMarkup id a = Markup {
markupEmpty :: a,
markupString :: String -> a,
markupParagraph :: a -> a,
markupAppend :: a -> a -> a,
markupIdentifier :: id -> a,
markupModule :: String -> a,
markupEmphasis :: a -> a,
markupMonospaced :: a -> a,
markupUnorderedList :: [a] -> a,
markupOrderedList :: [a] -> a,
markupDefList :: [(a,a)] -> a,
markupCodeBlock :: a -> a,
markupURL :: String -> a,
markupPic :: String -> a,
markupAName :: String -> a
}
markup :: DocMarkup id a -> GenDoc id -> a
markup m DocEmpty = markupEmpty m
markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
markup m (DocString s) = markupString m s
markup m (DocParagraph d) = markupParagraph m (markup m d)
markup m (DocIdentifier i) = markupIdentifier m i
markup m (DocModule mod0) = markupModule m mod0
markup m (DocEmphasis d) = markupEmphasis m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
markup m (DocURL url) = markupURL m url
markup m (DocPic url) = markupPic m url
markup m (DocAName ref) = markupAName m ref
markupPair :: DocMarkup id a -> (GenDoc id, GenDoc id) -> (a, a)
markupPair m (a,b) = (markup m a, markup m b)
-- | The identity markup
idMarkup :: DocMarkup a (GenDoc a)
idMarkup = Markup {
markupEmpty = DocEmpty,
markupString = DocString,
markupParagraph = DocParagraph,
markupAppend = DocAppend,
markupIdentifier = DocIdentifier,
markupModule = DocModule,
markupEmphasis = DocEmphasis,
markupMonospaced = DocMonospaced,
markupUnorderedList = DocUnorderedList,
markupOrderedList = DocOrderedList,
markupDefList = DocDefList,
markupCodeBlock = DocCodeBlock,
markupURL = DocURL,
markupPic = DocPic,
markupAName = DocAName
}
htmlMarkup :: DocMarkup String Html
htmlMarkup = Markup {
markupParagraph = paragraph,
markupEmpty = toHtml "",
markupString = toHtml,
markupAppend = (+++),
markupIdentifier = tt . toHtml . init . tail,
markupModule = tt . toHtml,
markupEmphasis = emphasize . toHtml,
markupMonospaced = tt . toHtml,
markupUnorderedList = ulist . concatHtml . map (li <<),
markupOrderedList = olist . concatHtml . map (li <<),
markupDefList = dlist . concatHtml . map markupDef,
markupCodeBlock = pre,
markupURL = \url -> anchor ! [href url] << toHtml url,
markupPic = \url -> image ! [src url],
markupAName = \aname -> namedAnchor aname << toHtml ""
}
where markupDef (a,b) = dterm << a +++ ddef << b
namedAnchor :: String -> Html -> Html
namedAnchor n = anchor ! [name (escapeStr n)]
escapeStr :: String -> String
escapeStr = escapeURIString isUnreserved
-- -----------------------------------------------------------------------------
-- ** Smart constructors
-- used to make parsing easier; we group the list items later
docAppend :: Doc -> Doc -> Doc
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
= DocUnorderedList (ds1++ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
= DocAppend (DocUnorderedList (ds1++ds2)) d
docAppend (DocOrderedList ds1) (DocOrderedList ds2)
= DocOrderedList (ds1++ds2)
docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
= DocAppend (DocOrderedList (ds1++ds2)) d
docAppend (DocDefList ds1) (DocDefList ds2)
= DocDefList (ds1++ds2)
docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
= DocAppend (DocDefList (ds1++ds2)) d
docAppend DocEmpty d = d
docAppend d DocEmpty = d
docAppend d1 d2
= DocAppend d1 d2
-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
docParagraph :: Doc -> Doc
docParagraph (DocMonospaced p)
= DocCodeBlock p
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
| all isSpace s1
= DocCodeBlock p
docParagraph (DocAppend (DocString s1)
(DocAppend (DocMonospaced p) (DocString s2)))
| all isSpace s1 && all isSpace s2
= DocCodeBlock p
docParagraph (DocAppend (DocMonospaced p) (DocString s2))
| all isSpace s2
= DocCodeBlock p
docParagraph p
= DocParagraph p