module Text.PrettyPrint.Html (
HtmlDocument(..)
, withTag
, withTagNonEmpty
, closedTag
, module Text.PrettyPrint.Highlight
, HtmlDoc
, htmlDoc
, getHtmlDoc
, postprocessHtmlDoc
, renderHtmlDoc
, noHtmlDoc
, getNoHtmlDoc
) where
import Data.Char (isSpace)
import Data.Traversable (sequenceA)
import Data.Monoid
import Control.Arrow (first)
import Control.Applicative
import Control.Monad.Identity
import Control.DeepSeq
import Text.PrettyPrint.Class
import Text.PrettyPrint.Highlight
class HighlightDocument d => HtmlDocument d where
unescapedText :: String -> d
unescapedZeroWidthText :: String -> d
withTag :: HtmlDocument d => String -> [(String,String)] -> d -> d
withTag tag attrs inner =
unescapedZeroWidthText open <> inner <> unescapedZeroWidthText close
where
open = "<" ++ tag ++ concatMap attribute attrs ++ ">"
close = "</" ++ tag ++ ">"
closedTag :: HtmlDocument d => String -> [(String,String)] -> d
closedTag tag attrs =
unescapedZeroWidthText $ "<" ++ tag ++ concatMap attribute attrs ++ "/>"
withTagNonEmpty :: HtmlDocument d => String -> [(String,String)] -> d -> d
withTagNonEmpty tag attrs inner =
caseEmptyDoc inner emptyDoc $ withTag tag attrs inner
attribute :: (String, String) -> String
attribute (key,value) = " " ++ key ++ "=\"" ++ escapeHtmlEntities value ++ "\""
newtype HtmlDoc d = HtmlDoc { getHtmlDoc :: d }
deriving( Monoid )
htmlDoc :: d -> HtmlDoc d
htmlDoc = HtmlDoc
instance NFData d => NFData (HtmlDoc d) where
rnf = rnf . getHtmlDoc
instance Document d => Document (HtmlDoc d) where
char = HtmlDoc . text . escapeHtmlEntities . return
text = HtmlDoc . text . escapeHtmlEntities
zeroWidthText = HtmlDoc . zeroWidthText . escapeHtmlEntities
HtmlDoc d1 <-> HtmlDoc d2 = HtmlDoc $ d1 <-> d2
hcat = HtmlDoc . hcat . map getHtmlDoc
hsep = HtmlDoc . hsep . map getHtmlDoc
HtmlDoc d1 $$ HtmlDoc d2 = HtmlDoc $ d1 $$ d2
HtmlDoc d1 $-$ HtmlDoc d2 = HtmlDoc $ d1 $-$ d2
vcat = HtmlDoc . vcat . map getHtmlDoc
sep = HtmlDoc . sep . map getHtmlDoc
cat = HtmlDoc . cat . map getHtmlDoc
fsep = HtmlDoc . fsep . map getHtmlDoc
fcat = HtmlDoc . fcat . map getHtmlDoc
nest i = HtmlDoc . nest i . getHtmlDoc
caseEmptyDoc (HtmlDoc d1) (HtmlDoc d2) (HtmlDoc d3) =
HtmlDoc $ caseEmptyDoc d1 d2 d3
instance Document d => HtmlDocument (HtmlDoc d) where
unescapedText = HtmlDoc . text
unescapedZeroWidthText = HtmlDoc . zeroWidthText
instance Document d => HighlightDocument (HtmlDoc d) where
highlight hlStyle =
withTag "span" [("class", hlClass hlStyle)]
where
hlClass Comment = "hl_comment"
hlClass Keyword = "hl_keyword"
hlClass Operator = "hl_operator"
escapeHtmlEntities :: String
-> String
escapeHtmlEntities [] = []
escapeHtmlEntities (c:cs) = case c of
'<' -> "<" ++ escapeHtmlEntities cs
'>' -> ">" ++ escapeHtmlEntities cs
'&' -> "&" ++ escapeHtmlEntities cs
'"' -> """ ++ escapeHtmlEntities cs
'\'' -> "'" ++ escapeHtmlEntities cs
x -> x : escapeHtmlEntities cs
renderHtmlDoc :: HtmlDoc Doc -> String
renderHtmlDoc = postprocessHtmlDoc . render . getHtmlDoc
postprocessHtmlDoc :: String -> String
postprocessHtmlDoc =
unlines . map (addBreak . indent) . lines
where
addBreak = (++"<br/>")
indent = uncurry (++) . (first $ concatMap (const " ")) . span isSpace
newtype NoHtmlDoc d = NoHtmlDoc { unNoHtmlDoc :: Identity d }
deriving( Functor, Applicative )
noHtmlDoc :: d -> NoHtmlDoc d
noHtmlDoc = NoHtmlDoc . Identity
getNoHtmlDoc :: NoHtmlDoc d -> d
getNoHtmlDoc = runIdentity . unNoHtmlDoc
instance NFData d => NFData (NoHtmlDoc d) where
rnf = rnf . getNoHtmlDoc
instance Monoid d => Monoid (NoHtmlDoc d) where
mempty = pure mempty
mappend = liftA2 mappend
instance Document d => Document (NoHtmlDoc d) where
char = pure . char
text = pure . text
zeroWidthText = pure . zeroWidthText
(<->) = liftA2 (<->)
hcat = liftA hcat . sequenceA
hsep = liftA hsep . sequenceA
($$) = liftA2 ($$)
($-$) = liftA2 ($-$)
vcat = liftA vcat . sequenceA
sep = liftA sep . sequenceA
cat = liftA cat . sequenceA
fsep = liftA fsep . sequenceA
fcat = liftA fcat . sequenceA
nest = liftA2 nest . pure
caseEmptyDoc = liftA3 caseEmptyDoc
instance Document d => HtmlDocument (NoHtmlDoc d) where
unescapedText = noHtmlDoc . text
unescapedZeroWidthText = noHtmlDoc . zeroWidthText
instance Document d => HighlightDocument (NoHtmlDoc d) where
highlight _ = id