module Comark.Html
( render ) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Writer.Strict
import Data.Char
import Data.Maybe (maybeToList)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder
(Builder, fromString, fromText, singleton, toLazyText)
import Numeric (showIntAtBase)
import Prelude
import Data.Bits (shiftR, (.&.))
import Comark.Syntax
render :: Doc Text -> Text
render (Doc bs) =
toStrict $ toLazyText $ buildHtml $ renderBlocks bs
type HtmlBuilder = WriterT Builder (State BuilderState) ()
newtype BuilderState
= BuilderState
{ newlineAllowed :: Bool }
type Attribute = (String,Text)
buildAttr :: Attribute -> Builder
buildAttr (name,val) =
singleton ' ' <> fromString name <> "=\"" <> escapedHtml val <> singleton '"'
type TagName = String
type TagContent = HtmlBuilder
tagWith :: [Attribute] -> TagName -> TagContent -> HtmlBuilder
tagWith !attrs !t content = do
let !tagNameBuilder = fromString t
tell (singleton '<' <> tagNameBuilder <> foldMap buildAttr attrs <> singleton '>')
allowNL
content
tell ("</" <> tagNameBuilder <> singleton '>')
allowNL
tag :: TagName -> TagContent -> HtmlBuilder
tag = tagWith []
voidTag :: TagName -> HtmlBuilder
voidTag = voidTagWith []
voidTagWith :: [Attribute] -> TagName -> HtmlBuilder
voidTagWith !attrs !t = do
tell $ singleton '<' <> fromString t <> foldMap buildAttr attrs <> " />"
allowNL
allowNL, disallowNL :: HtmlBuilder
allowNL = lift $ put (BuilderState True)
disallowNL = lift $ put (BuilderState False)
nl :: HtmlBuilder
nl = do
allowed <- lift $ gets newlineAllowed
when allowed $ do
tell "\n"
disallowNL
escapedText :: Text -> HtmlBuilder
escapedText t = tell (escapedHtml t) *> allowNL
unescapedText :: Text -> HtmlBuilder
unescapedText t = tell (fromText t) *> allowNL
buildHtml :: HtmlBuilder -> Builder
buildHtml m = evalState (execWriterT m) (BuilderState False)
renderBlocks :: Blocks Text -> HtmlBuilder
renderBlocks bs = nl *> mapM_ (\b -> nl *> renderBlock b *> nl) bs
renderBlock :: Block Text -> HtmlBuilder
renderBlock (Para is) = tag "p" (renderInlines is)
renderBlock (Heading n is) = tag hx (renderInlines is)
where
hx = case n of
Heading1 -> "h1"
Heading2 -> "h2"
Heading3 -> "h3"
Heading4 -> "h4"
Heading5 -> "h5"
Heading6 -> "h6"
renderBlock (CodeBlock mInfo t) =
tag "pre"
$ tagWith args "code"
$ escapedText t
where
args = ("class",) . lang <$> maybeToList mInfo
lang a = "language-" <> Text.takeWhile (/= ' ') a
renderBlock ThematicBreak = voidTag "hr"
renderBlock (HtmlBlock t) = unescapedText t
renderBlock (Quote bs) = tag "blockquote" $ renderBlocks bs
renderBlock (List listType tight items) =
case listType of
Bullet _ -> tag "ul" renderedItems
Ordered _ 1 -> tag "ol" renderedItems
Ordered _ n -> tagWith [("start", Text.pack $ show n)] "ol" renderedItems
where
renderedItems = nl *> mapM_ (\a -> renderItem a *> nl) items
renderItem bs
| tight = tag "li" (mapM_ renderTightBlock bs)
| otherwise = tag "li" (when (null bs) disallowNL *> renderBlocks bs)
renderTightBlock (Para zs) = mapM_ renderInline zs
renderTightBlock x = nl *> renderBlock x *> nl
renderInlines :: Inlines Text -> HtmlBuilder
renderInlines = mapM_ renderInline
renderInline :: Inline Text -> HtmlBuilder
renderInline (Str t) = escapedText t
renderInline SoftBreak = tell "\n"
renderInline HardBreak = voidTag "br" *> nl
renderInline (RawHtml t) = unescapedText t
renderInline (Emph is) = tag "em" (renderInlines is)
renderInline (Strong is) = tag "strong" (renderInlines is)
renderInline (Code t) = tag "code" (escapedText t)
renderInline (Link is dest title) = tagWith attrs "a" (renderInlines is)
where
attrs = ("href", encodeHref dest) : maybeToList (("title",) <$> title)
renderInline (Image is dest title) = voidTagWith attrs "img"
where
attrs = ("src", encodeHref dest)
: ("alt", foldMap asText is)
: (("title",) <$> maybeToList title)
encodeHref :: Text -> Text
encodeHref = Text.concatMap (Text.pack . escapeURIChar predicate)
where
predicate c =
(isAscii c && isAlphaNum c) || (lightSpecialPred c && specialPred c)
lightSpecialPred c = c >= '!' && c <= '_'
specialPred c =
c == '-' || c == ',' || c == '+' || c == '$' || c == '/'
|| c == '_' || c == '.' || c == '+' || c == '!' || c == '*'
|| c == '\'' || c == '(' || c == ')' || c == ',' || c == '%'
|| c == '#' || c == '@' || c == '?' || c == '=' || c == ';'
|| c == ':' || c == '&'
escapeURIChar :: (Char -> Bool) -> Char -> String
escapeURIChar p c
| p c = [c]
| otherwise = concatMap (\i -> '%' : myShowHex i "") (utf8EncodeChar c)
where
myShowHex :: Int -> ShowS
myShowHex n r = case showIntAtBase 16 (toChrHex) n r of
[] -> "00"
[x] -> ['0',x]
cs -> cs
toChrHex d
| d < 10 = chr (ord '0' + fromIntegral d)
| otherwise = chr (ord 'A' + fromIntegral (d 10))
utf8EncodeChar :: Char -> [Int]
utf8EncodeChar = map fromIntegral . go . ord
where
go oc
| oc <= 0x7f = [oc]
| oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6)
, 0x80 + oc .&. 0x3f
]
| oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12)
, 0x80 + ((oc `shiftR` 6) .&. 0x3f)
, 0x80 + oc .&. 0x3f
]
| otherwise = [ 0xf0 + (oc `shiftR` 18)
, 0x80 + ((oc `shiftR` 12) .&. 0x3f)
, 0x80 + ((oc `shiftR` 6) .&. 0x3f)
, 0x80 + oc .&. 0x3f
]
escapedHtml :: Text -> Builder
escapedHtml =
fromText
. Text.replace ">" ">"
. Text.replace "<" "<"
. Text.replace "\"" """
. Text.replace "&" "&"