{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Commonmark.Html
( Html
, htmlInline
, htmlBlock
, htmlText
, htmlRaw
, addAttribute
, renderHtml
, escapeURI
, escapeHtml
)
where
import Commonmark.Types
import Commonmark.Entity (lookupEntity)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder, fromText, toLazyText,
singleton)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.ByteString.Char8 as B
import qualified Data.Set as Set
import Text.Printf (printf)
import Unicode.Char (ord, isAlphaNum, isAscii)
import Unicode.Char.General.Compat (isSpace)
import Data.Maybe (fromMaybe)
data ElementType =
InlineElement
| BlockElement
data Html a =
HtmlElement !ElementType {-# UNPACK #-} !Text [Attribute] (Maybe (Html a))
| HtmlText {-# UNPACK #-} !Text
| HtmlRaw {-# UNPACK #-} !Text
| HtmlNull
| HtmlConcat !(Html a) !(Html a)
instance Show (Html a) where
show :: Html a -> String
show = Text -> String
TL.unpack (Text -> String) -> (Html a -> Text) -> Html a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html a -> Text
forall a. Html a -> Text
renderHtml
instance Semigroup (Html a) where
x :: Html a
x <> :: Html a -> Html a -> Html a
<> HtmlNull = Html a
x
HtmlNull <> x :: Html a
x = Html a
x
HtmlText t1 :: Text
t1 <> HtmlText t2 :: Text
t2 = Text -> Html a
forall a. Text -> Html a
HtmlText (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2)
HtmlRaw t1 :: Text
t1 <> HtmlRaw t2 :: Text
t2 = Text -> Html a
forall a. Text -> Html a
HtmlRaw (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2)
x :: Html a
x <> y :: Html a
y = Html a -> Html a -> Html a
forall a. Html a -> Html a -> Html a
HtmlConcat Html a
x Html a
y
instance Monoid (Html a) where
mempty :: Html a
mempty = Html a
forall a. Html a
HtmlNull
mappend :: Html a -> Html a -> Html a
mappend = Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
(<>)
instance HasAttributes (Html a) where
addAttributes :: Attributes -> Html a -> Html a
addAttributes attrs :: Attributes
attrs x :: Html a
x = (Attribute -> Html a -> Html a) -> Html a -> Attributes -> Html a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute Html a
x Attributes
attrs
instance ToPlainText (Html a) where
toPlainText :: Html a -> Text
toPlainText h :: Html a
h =
case Html a
h of
HtmlElement InlineElement "span" attr :: Attributes
attr (Just x :: Html a
x)
-> case Text -> Attributes -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "data-emoji" Attributes
attr of
Just alias :: Text
alias -> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
alias Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":"
Nothing -> Html a -> Text
forall a. ToPlainText a => a -> Text
toPlainText Html a
x
HtmlElement _ _ _ (Just x :: Html a
x) -> Html a -> Text
forall a. ToPlainText a => a -> Text
toPlainText Html a
x
HtmlElement _ _ attrs :: Attributes
attrs Nothing
-> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
forall a. Monoid a => a
mempty (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "alt" Attributes
attrs
HtmlText t :: Text
t -> Text
t
HtmlConcat x :: Html a
x y :: Html a
y -> Html a -> Text
forall a. ToPlainText a => a -> Text
toPlainText Html a
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Html a -> Text
forall a. ToPlainText a => a -> Text
toPlainText Html a
y
_ -> Text
forall a. Monoid a => a
mempty
instance Rangeable (Html a) => IsInline (Html a) where
lineBreak :: Html a
lineBreak = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline "br" Maybe (Html a)
forall a. Maybe a
Nothing Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
forall a. Html a
nl
softBreak :: Html a
softBreak = Html a
forall a. Html a
nl
str :: Text -> Html a
str t :: Text
t = Text -> Html a
forall a. Text -> Html a
htmlText Text
t
entity :: Text -> Html a
entity t :: Text
t = case Text -> Maybe Text
lookupEntity (Int -> Text -> Text
T.drop 1 Text
t) of
Just t' :: Text
t' -> Text -> Html a
forall a. Text -> Html a
htmlText Text
t'
Nothing -> Text -> Html a
forall a. Text -> Html a
htmlRaw Text
t
escapedChar :: Char -> Html a
escapedChar c :: Char
c = Text -> Html a
forall a. Text -> Html a
htmlText (Char -> Text
T.singleton Char
c)
emph :: Html a -> Html a
emph ils :: Html a
ils = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline "em" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
strong :: Html a -> Html a
strong ils :: Html a
ils = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline "strong" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
link :: Text -> Text -> Html a -> Html a
link target :: Text
target title :: Text
title ils :: Html a
ils =
Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("href", Text -> Text
escapeURI Text
target) (Html a -> Html a) -> (Html a -> Html a) -> Html a -> Html a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if Text -> Bool
T.null Text
title
then Html a -> Html a
forall a. a -> a
id
else Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("title", Text
title)) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline "a" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
image :: Text -> Text -> Html a -> Html a
image target :: Text
target title :: Text
title ils :: Html a
ils =
Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("src", Text -> Text
escapeURI Text
target) (Html a -> Html a) -> (Html a -> Html a) -> Html a -> Html a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("alt", Html a -> Text
forall a. ToPlainText a => a -> Text
toPlainText Html a
ils) (Html a -> Html a) -> (Html a -> Html a) -> Html a -> Html a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if Text -> Bool
T.null Text
title
then Html a -> Html a
forall a. a -> a
id
else Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("title", Text
title)) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline "img" Maybe (Html a)
forall a. Maybe a
Nothing
code :: Text -> Html a
code t :: Text
t = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline "code" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Text -> Html a
forall a. Text -> Html a
htmlText Text
t))
rawInline :: Format -> Text -> Html a
rawInline f :: Format
f t :: Text
t
| Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Format
Format "html" = Text -> Html a
forall a. Text -> Html a
htmlRaw Text
t
| Bool
otherwise = Html a
forall a. Monoid a => a
mempty
instance IsInline (Html a) => IsBlock (Html a) (Html a) where
paragraph :: Html a -> Html a
paragraph ils :: Html a
ils = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "p" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
plain :: Html a -> Html a
plain ils :: Html a
ils = Html a
ils Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
forall a. Html a
nl
thematicBreak :: Html a
thematicBreak = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "hr" Maybe (Html a)
forall a. Maybe a
Nothing
blockQuote :: Html a -> Html a
blockQuote bs :: Html a
bs = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "blockquote" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a
forall a. Html a
nl Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
bs)
codeBlock :: Text -> Text -> Html a
codeBlock info :: Text
info t :: Text
t =
Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "pre" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$
(if Text -> Bool
T.null Text
lang
then Html a -> Html a
forall a. a -> a
id
else Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("class", "language-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lang)) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline "code" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Text -> Html a
forall a. Text -> Html a
htmlText Text
t)
where lang :: Text
lang = (Char -> Bool) -> Text -> Text
T.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
info
heading :: Int -> Html a -> Html a
heading level :: Int
level ils :: Html a
ils = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
h (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
where h :: Text
h = case Int
level of
1 -> "h1"
2 -> "h2"
3 -> "h3"
4 -> "h4"
5 -> "h5"
6 -> "h6"
_ -> "p"
rawBlock :: Format -> Text -> Html a
rawBlock f :: Format
f t :: Text
t
| Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Format
Format "html" = Text -> Html a
forall a. Text -> Html a
htmlRaw Text
t
| Bool
otherwise = Html a
forall a. Monoid a => a
mempty
referenceLinkDefinition :: Text -> Attribute -> Html a
referenceLinkDefinition _ _ = Html a
forall a. Monoid a => a
mempty
list :: ListType -> ListSpacing -> [Html a] -> Html a
list (BulletList _) lSpacing :: ListSpacing
lSpacing items :: [Html a]
items =
Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "ul" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a
forall a. Html a
nl Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> [Html a] -> Html a
forall a. Monoid a => [a] -> a
mconcat ((Html a -> Html a) -> [Html a] -> [Html a]
forall a b. (a -> b) -> [a] -> [b]
map Html a -> Html a
forall a. Html a -> Html a
li [Html a]
items))
where li :: Html a -> Html a
li x :: Html a
x = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "li" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$
Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just ((if ListSpacing
lSpacing ListSpacing -> ListSpacing -> Bool
forall a. Eq a => a -> a -> Bool
== ListSpacing
TightList
then Html a
forall a. Monoid a => a
mempty
else Html a
forall a. Html a
nl) Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
x)
list (OrderedList startnum :: Int
startnum enumtype :: EnumeratorType
enumtype _delimtype :: DelimiterType
_delimtype) lSpacing :: ListSpacing
lSpacing items :: [Html a]
items =
(if Int
startnum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 1
then Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("start", String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
startnum))
else Html a -> Html a
forall a. a -> a
id) (Html a -> Html a) -> (Html a -> Html a) -> Html a -> Html a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(case EnumeratorType
enumtype of
Decimal -> Html a -> Html a
forall a. a -> a
id
UpperAlpha -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("type", "A")
LowerAlpha -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("type", "a")
UpperRoman -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("type", "I")
LowerRoman -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute ("type", "i"))
(Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "ol" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$
Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a
forall a. Html a
nl Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> [Html a] -> Html a
forall a. Monoid a => [a] -> a
mconcat ((Html a -> Html a) -> [Html a] -> [Html a]
forall a b. (a -> b) -> [a] -> [b]
map Html a -> Html a
forall a. Html a -> Html a
li [Html a]
items))
where li :: Html a -> Html a
li x :: Html a
x = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock "li" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$
Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just ((if ListSpacing
lSpacing ListSpacing -> ListSpacing -> Bool
forall a. Eq a => a -> a -> Bool
== ListSpacing
TightList
then Html a
forall a. Monoid a => a
mempty
else Html a
forall a. Html a
nl) Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
x)
nl :: Html a
nl :: Html a
nl = Text -> Html a
forall a. Text -> Html a
htmlRaw "\n"
instance Rangeable (Html ()) where
ranged :: SourceRange -> Html () -> Html ()
ranged _ x :: Html ()
x = Html ()
x
instance Rangeable (Html SourceRange) where
ranged :: SourceRange -> Html SourceRange -> Html SourceRange
ranged sr :: SourceRange
sr x :: Html SourceRange
x = Attribute -> Html SourceRange -> Html SourceRange
forall a. Attribute -> Html a -> Html a
addAttribute ("data-sourcepos", String -> Text
T.pack (SourceRange -> String
forall a. Show a => a -> String
show SourceRange
sr)) Html SourceRange
x
htmlInline :: Text -> Maybe (Html a) -> Html a
htmlInline :: Text -> Maybe (Html a) -> Html a
htmlInline tagname :: Text
tagname = ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
forall a.
ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
HtmlElement ElementType
InlineElement Text
tagname []
htmlBlock :: Text -> Maybe (Html a) -> Html a
htmlBlock :: Text -> Maybe (Html a) -> Html a
htmlBlock tagname :: Text
tagname mbcontents :: Maybe (Html a)
mbcontents = ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
forall a.
ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
HtmlElement ElementType
BlockElement Text
tagname [] Maybe (Html a)
mbcontents
htmlText :: Text -> Html a
htmlText :: Text -> Html a
htmlText = Text -> Html a
forall a. Text -> Html a
HtmlText
htmlRaw :: Text -> Html a
htmlRaw :: Text -> Html a
htmlRaw = Text -> Html a
forall a. Text -> Html a
HtmlRaw
addAttribute :: Attribute -> Html a -> Html a
addAttribute :: Attribute -> Html a -> Html a
addAttribute attr :: Attribute
attr (HtmlElement eltType :: ElementType
eltType tagname :: Text
tagname attrs :: Attributes
attrs mbcontents :: Maybe (Html a)
mbcontents) =
ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
forall a.
ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
HtmlElement ElementType
eltType Text
tagname (Attribute -> Attributes -> Attributes
incorporateAttribute Attribute
attr Attributes
attrs) Maybe (Html a)
mbcontents
addAttribute attr :: Attribute
attr (HtmlText t :: Text
t)
= Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute Attribute
attr (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$ ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
forall a.
ElementType -> Text -> Attributes -> Maybe (Html a) -> Html a
HtmlElement ElementType
InlineElement "span" [] (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Text -> Html a
forall a. Text -> Html a
HtmlText Text
t)
addAttribute _ elt :: Html a
elt = Html a
elt
incorporateAttribute :: Attribute -> [Attribute] -> [Attribute]
incorporateAttribute :: Attribute -> Attributes -> Attributes
incorporateAttribute (k :: Text
k, v :: Text
v) as :: Attributes
as =
case Text -> Attributes -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k' Attributes
as of
Nothing -> (Text
k', Text
v) Attribute -> Attributes -> Attributes
forall a. a -> [a] -> [a]
: Attributes
as
Just v' :: Text
v' -> (if Text
k' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "class"
then ("class", Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v')
else (Text
k', Text
v')) Attribute -> Attributes -> Attributes
forall a. a -> [a] -> [a]
:
(Attribute -> Bool) -> Attributes -> Attributes
forall a. (a -> Bool) -> [a] -> [a]
filter (\(x :: Text
x, _) -> Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
k') Attributes
as
where
k' :: Text
k' = if Text
k Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
html5Attributes
Bool -> Bool -> Bool
|| "data-" Text -> Text -> Bool
`T.isPrefixOf` Text
k
then Text
k
else "data-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k
html5Attributes :: Set.Set Text
html5Attributes :: Set Text
html5Attributes = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[ "abbr"
, "accept"
, "accept-charset"
, "accesskey"
, "action"
, "allow"
, "allowfullscreen"
, "allowpaymentrequest"
, "allowusermedia"
, "alt"
, "as"
, "async"
, "autocapitalize"
, "autocomplete"
, "autofocus"
, "autoplay"
, "charset"
, "checked"
, "cite"
, "class"
, "color"
, "cols"
, "colspan"
, "content"
, "contenteditable"
, "controls"
, "coords"
, "crossorigin"
, "data"
, "datetime"
, "decoding"
, "default"
, "defer"
, "dir"
, "dirname"
, "disabled"
, "download"
, "draggable"
, "enctype"
, "enterkeyhint"
, "for"
, "form"
, "formaction"
, "formenctype"
, "formmethod"
, "formnovalidate"
, "formtarget"
, "headers"
, "height"
, "hidden"
, "high"
, "href"
, "hreflang"
, "http-equiv"
, "id"
, "imagesizes"
, "imagesrcset"
, "inputmode"
, "integrity"
, "is"
, "ismap"
, "itemid"
, "itemprop"
, "itemref"
, "itemscope"
, "itemtype"
, "kind"
, "label"
, "lang"
, "list"
, "loading"
, "loop"
, "low"
, "manifest"
, "max"
, "maxlength"
, "media"
, "method"
, "min"
, "minlength"
, "multiple"
, "muted"
, "name"
, "nomodule"
, "nonce"
, "novalidate"
, "onabort"
, "onafterprint"
, "onauxclick"
, "onbeforeprint"
, "onbeforeunload"
, "onblur"
, "oncancel"
, "oncanplay"
, "oncanplaythrough"
, "onchange"
, "onclick"
, "onclose"
, "oncontextmenu"
, "oncopy"
, "oncuechange"
, "oncut"
, "ondblclick"
, "ondrag"
, "ondragend"
, "ondragenter"
, "ondragexit"
, "ondragleave"
, "ondragover"
, "ondragstart"
, "ondrop"
, "ondurationchange"
, "onemptied"
, "onended"
, "onerror"
, "onfocus"
, "onhashchange"
, "oninput"
, "oninvalid"
, "onkeydown"
, "onkeypress"
, "onkeyup"
, "onlanguagechange"
, "onload"
, "onloadeddata"
, "onloadedmetadata"
, "onloadend"
, "onloadstart"
, "onmessage"
, "onmessageerror"
, "onmousedown"
, "onmouseenter"
, "onmouseleave"
, "onmousemove"
, "onmouseout"
, "onmouseover"
, "onmouseup"
, "onoffline"
, "ononline"
, "onpagehide"
, "onpageshow"
, "onpaste"
, "onpause"
, "onplay"
, "onplaying"
, "onpopstate"
, "onprogress"
, "onratechange"
, "onrejectionhandled"
, "onreset"
, "onresize"
, "onscroll"
, "onsecuritypolicyviolation"
, "onseeked"
, "onseeking"
, "onselect"
, "onstalled"
, "onstorage"
, "onsubmit"
, "onsuspend"
, "ontimeupdate"
, "ontoggle"
, "onunhandledrejection"
, "onunload"
, "onvolumechange"
, "onwaiting"
, "onwheel"
, "open"
, "optimum"
, "pattern"
, "ping"
, "placeholder"
, "playsinline"
, "poster"
, "preload"
, "readonly"
, "referrerpolicy"
, "rel"
, "required"
, "reversed"
, "role"
, "rows"
, "rowspan"
, "sandbox"
, "scope"
, "selected"
, "shape"
, "size"
, "sizes"
, "slot"
, "span"
, "spellcheck"
, "src"
, "srcdoc"
, "srclang"
, "srcset"
, "start"
, "step"
, "style"
, "tabindex"
, "target"
, "title"
, "translate"
, "type"
, "typemustmatch"
, "updateviacache"
, "usemap"
, "value"
, "width"
, "workertype"
, "wrap"
]
renderHtml :: Html a -> TL.Text
renderHtml :: Html a -> Text
renderHtml = {-# SCC renderHtml #-} Builder -> Text
toLazyText (Builder -> Text) -> (Html a -> Builder) -> Html a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html a -> Builder
forall a. Html a -> Builder
toBuilder
toBuilder :: Html a -> Builder
toBuilder :: Html a -> Builder
toBuilder HtmlNull = Builder
forall a. Monoid a => a
mempty
toBuilder (HtmlConcat x :: Html a
x y :: Html a
y) = Html a -> Builder
forall a. Html a -> Builder
toBuilder Html a
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Html a -> Builder
forall a. Html a -> Builder
toBuilder Html a
y
toBuilder (HtmlRaw t :: Text
t) = Text -> Builder
fromText Text
t
toBuilder (HtmlText t :: Text
t) = Text -> Builder
escapeHtml Text
t
toBuilder (HtmlElement eltType :: ElementType
eltType tagname :: Text
tagname attrs :: Attributes
attrs mbcontents :: Maybe (Html a)
mbcontents) =
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
tagname Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Attribute -> Builder) -> Attributes -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Builder
toAttr Attributes
attrs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
filling Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nl'
where
toAttr :: Attribute -> Builder
toAttr (x :: Text
x,y :: Text
y) = " " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "=\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escapeHtml Text
y Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "\""
nl' :: Builder
nl' = case ElementType
eltType of
BlockElement -> "\n"
_ -> Builder
forall a. Monoid a => a
mempty
filling :: Builder
filling = case Maybe (Html a)
mbcontents of
Nothing -> " />"
Just cont :: Html a
cont -> ">" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Html a -> Builder
forall a. Html a -> Builder
toBuilder Html a
cont Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
fromText Text
tagname Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ">"
escapeHtml :: Text -> Builder
escapeHtml :: Text -> Builder
escapeHtml t :: Text
t =
case Text -> Maybe (Char, Text)
T.uncons Text
post of
Just (c :: Char
c, rest :: Text
rest) -> Text -> Builder
fromText Text
pre Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
escapeHtmlChar Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escapeHtml Text
rest
Nothing -> Text -> Builder
fromText Text
pre
where
(pre :: Text
pre,post :: Text
post) = (Char -> Bool) -> Text -> Attribute
T.break Char -> Bool
needsEscaping Text
t
needsEscaping :: Char -> Bool
needsEscaping '<' = Bool
True
needsEscaping '>' = Bool
True
needsEscaping '&' = Bool
True
needsEscaping '"' = Bool
True
needsEscaping _ = Bool
False
escapeHtmlChar :: Char -> Builder
escapeHtmlChar :: Char -> Builder
escapeHtmlChar '<' = "<"
escapeHtmlChar '>' = ">"
escapeHtmlChar '&' = "&"
escapeHtmlChar '"' = """
escapeHtmlChar c :: Char
c = Char -> Builder
singleton Char
c
escapeURI :: Text -> Text
escapeURI :: Text -> Text
escapeURI = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
escapeURIChar (String -> [Text]) -> (Text -> String) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> String) -> (Text -> ByteString) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
escapeURIChar :: Char -> Text
escapeURIChar :: Char -> Text
escapeURIChar c :: Char
c
| Char -> Bool
isEscapable Char
c = Char -> Text
T.singleton '%' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> Int -> String
forall r. PrintfType r => String -> r
printf "%02X" (Char -> Int
ord Char
c))
| Bool
otherwise = Char -> Text
T.singleton Char
c
where isEscapable :: Char -> Bool
isEscapable d :: Char
d = Bool -> Bool
not (Char -> Bool
isAscii Char
d Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
d)
Bool -> Bool -> Bool
&& Char
d Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ['%','/','?',':','@','-','.','_','~','&',
'#','!','$','\'','(',')','*','+',',',
';','=']