{-# 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
  Html a
x <> :: Html a -> Html a -> Html a
<> Html a
HtmlNull                = Html a
x
  Html a
HtmlNull <> Html a
x                = Html a
x
  HtmlText Text
t1 <> HtmlText 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 Text
t1 <> HtmlRaw 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)
  Html a
x <> 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 Attributes
attrs Html a
x = (Attribute -> Html a -> Html a) -> Html a -> Attributes -> Html a
forall a b. (a -> b -> b) -> b -> [a] -> b
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 Html a
h =
    case Html a
h of
      HtmlElement ElementType
InlineElement Text
"span" Attributes
attr (Just Html a
x)
        -> case Text -> Attributes -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"data-emoji" Attributes
attr of
              Just Text
alias -> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
alias Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
              Maybe Text
Nothing    -> Html a -> Text
forall a. ToPlainText a => a -> Text
toPlainText Html a
x
      HtmlElement ElementType
_ Text
_ Attributes
_ (Just Html a
x) -> Html a -> Text
forall a. ToPlainText a => a -> Text
toPlainText Html a
x
      HtmlElement ElementType
_ Text
_ Attributes
attrs Maybe (Html a)
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 Text
"alt" Attributes
attrs
      HtmlText Text
t                 -> Text
t
      HtmlConcat Html a
x 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
      Html a
_                          -> Text
forall a. Monoid a => a
mempty


-- This instance mirrors what is expected in the spec tests.
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 Text
"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 Text
t = Text -> Html a
forall a. Text -> Html a
htmlText Text
t
  entity :: Text -> Html a
entity Text
t = case Text -> Maybe Text
lookupEntity (Int -> Text -> Text
T.drop Int
1 Text
t) of
                   Just Text
t' -> Text -> Html a
forall a. Text -> Html a
htmlText Text
t'
                   Maybe Text
Nothing -> Text -> Html a
forall a. Text -> Html a
htmlRaw Text
t
  escapedChar :: Char -> Html a
escapedChar Char
c = Text -> Html a
forall a. Text -> Html a
htmlText (Char -> Text
T.singleton Char
c)
  emph :: Html a -> Html a
emph Html a
ils = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"em" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
  strong :: Html a -> Html a
strong Html a
ils = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"strong" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
  link :: Text -> Text -> Html a -> Html a
link Text
target Text
title Html a
ils =
    Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"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 (Text
"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 Text
"a" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
  image :: Text -> Text -> Html a -> Html a
image Text
target Text
title Html a
ils =
    Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"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 (Text
"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 (Text
"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 Text
"img" Maybe (Html a)
forall a. Maybe a
Nothing
  code :: Text -> Html a
code Text
t = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"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 Format
f Text
t
    | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Format
Format Text
"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 Html a
ils = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"p" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)
  plain :: Html a -> Html a
plain 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 Text
"hr" Maybe (Html a)
forall a. Maybe a
Nothing
  blockQuote :: Html a -> Html a
blockQuote Html a
bs = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"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 Text
info Text
t =
    Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"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 (Text
"class", Text
"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 Text
"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 Int
level 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
                   Int
1 -> Text
"h1"
                   Int
2 -> Text
"h2"
                   Int
3 -> Text
"h3"
                   Int
4 -> Text
"h4"
                   Int
5 -> Text
"h5"
                   Int
6 -> Text
"h6"
                   Int
_ -> Text
"p"
  rawBlock :: Format -> Text -> Html a
rawBlock Format
f Text
t
    | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Format
Format Text
"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 Text
_ Attribute
_ = Html a
forall a. Monoid a => a
mempty
  list :: ListType -> ListSpacing -> [Html a] -> Html a
list (BulletList Char
_) ListSpacing
lSpacing [Html a]
items =
    Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"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 Html a
x = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"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 Int
startnum EnumeratorType
enumtype DelimiterType
_delimtype) ListSpacing
lSpacing [Html a]
items =
    (if Int
startnum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
        then Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"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
       EnumeratorType
Decimal  -> Html a -> Html a
forall a. a -> a
id
       EnumeratorType
UpperAlpha -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"type", Text
"A")
       EnumeratorType
LowerAlpha -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"type", Text
"a")
       EnumeratorType
UpperRoman -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"type", Text
"I")
       EnumeratorType
LowerRoman -> Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"type", Text
"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 Text
"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 Html a
x = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"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 :: forall a. Html a
nl = Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n"

instance Rangeable (Html ()) where
  ranged :: SourceRange -> Html () -> Html ()
ranged SourceRange
_ Html ()
x = Html ()
x

instance Rangeable (Html SourceRange) where
  ranged :: SourceRange -> Html SourceRange -> Html SourceRange
ranged SourceRange
sr Html SourceRange
x = Attribute -> Html SourceRange -> Html SourceRange
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"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 :: forall a. Text -> Maybe (Html a) -> Html a
htmlInline 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 :: forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
tagname 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 :: forall a. Text -> Html a
htmlText = Text -> Html a
forall a. Text -> Html a
HtmlText

htmlRaw :: Text -> Html a
htmlRaw :: forall a. Text -> Html a
htmlRaw = Text -> Html a
forall a. Text -> Html a
HtmlRaw

addAttribute :: Attribute -> Html a -> Html a
addAttribute :: forall a. Attribute -> Html a -> Html a
addAttribute Attribute
attr (HtmlElement ElementType
eltType Text
tagname Attributes
attrs 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 Attribute
attr (HtmlText 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 Text
"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 Attribute
_ Html a
elt = Html a
elt

incorporateAttribute :: Attribute -> [Attribute] -> [Attribute]
incorporateAttribute :: Attribute -> Attributes -> Attributes
incorporateAttribute (Text
k, Text
v) Attributes
as =
  case Text -> Attributes -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k' Attributes
as of
    Maybe Text
Nothing            -> (Text
k', Text
v) Attribute -> Attributes -> Attributes
forall a. a -> [a] -> [a]
: Attributes
as
    Just Text
v'            -> (if Text
k' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"class"
                              then (Text
"class", Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " 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 (\(Text
x, Text
_) -> 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
|| Text
"data-" Text -> Text -> Bool
`T.isPrefixOf` Text
k
          then Text
k
          else Text
"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
  [ Text
"abbr"
  , Text
"accept"
  , Text
"accept-charset"
  , Text
"accesskey"
  , Text
"action"
  , Text
"allow"
  , Text
"allowfullscreen"
  , Text
"allowpaymentrequest"
  , Text
"allowusermedia"
  , Text
"alt"
  , Text
"aria-hidden"
  , Text
"as"
  , Text
"async"
  , Text
"autocapitalize"
  , Text
"autocomplete"
  , Text
"autofocus"
  , Text
"autoplay"
  , Text
"charset"
  , Text
"checked"
  , Text
"cite"
  , Text
"class"
  , Text
"color"
  , Text
"cols"
  , Text
"colspan"
  , Text
"content"
  , Text
"contenteditable"
  , Text
"controls"
  , Text
"coords"
  , Text
"crossorigin"
  , Text
"d"
  , Text
"data"
  , Text
"datetime"
  , Text
"decoding"
  , Text
"default"
  , Text
"defer"
  , Text
"dir"
  , Text
"dirname"
  , Text
"disabled"
  , Text
"download"
  , Text
"draggable"
  , Text
"enctype"
  , Text
"enterkeyhint"
  , Text
"for"
  , Text
"form"
  , Text
"formaction"
  , Text
"formenctype"
  , Text
"formmethod"
  , Text
"formnovalidate"
  , Text
"formtarget"
  , Text
"headers"
  , Text
"height"
  , Text
"hidden"
  , Text
"high"
  , Text
"href"
  , Text
"hreflang"
  , Text
"http-equiv"
  , Text
"id"
  , Text
"imagesizes"
  , Text
"imagesrcset"
  , Text
"inputmode"
  , Text
"integrity"
  , Text
"is"
  , Text
"ismap"
  , Text
"itemid"
  , Text
"itemprop"
  , Text
"itemref"
  , Text
"itemscope"
  , Text
"itemtype"
  , Text
"kind"
  , Text
"label"
  , Text
"lang"
  , Text
"list"
  , Text
"loading"
  , Text
"loop"
  , Text
"low"
  , Text
"manifest"
  , Text
"max"
  , Text
"maxlength"
  , Text
"media"
  , Text
"method"
  , Text
"min"
  , Text
"minlength"
  , Text
"multiple"
  , Text
"muted"
  , Text
"name"
  , Text
"nomodule"
  , Text
"nonce"
  , Text
"novalidate"
  , Text
"onabort"
  , Text
"onafterprint"
  , Text
"onauxclick"
  , Text
"onbeforeprint"
  , Text
"onbeforeunload"
  , Text
"onblur"
  , Text
"oncancel"
  , Text
"oncanplay"
  , Text
"oncanplaythrough"
  , Text
"onchange"
  , Text
"onclick"
  , Text
"onclose"
  , Text
"oncontextmenu"
  , Text
"oncopy"
  , Text
"oncuechange"
  , Text
"oncut"
  , Text
"ondblclick"
  , Text
"ondrag"
  , Text
"ondragend"
  , Text
"ondragenter"
  , Text
"ondragexit"
  , Text
"ondragleave"
  , Text
"ondragover"
  , Text
"ondragstart"
  , Text
"ondrop"
  , Text
"ondurationchange"
  , Text
"onemptied"
  , Text
"onended"
  , Text
"onerror"
  , Text
"onfocus"
  , Text
"onhashchange"
  , Text
"oninput"
  , Text
"oninvalid"
  , Text
"onkeydown"
  , Text
"onkeypress"
  , Text
"onkeyup"
  , Text
"onlanguagechange"
  , Text
"onload"
  , Text
"onloadeddata"
  , Text
"onloadedmetadata"
  , Text
"onloadend"
  , Text
"onloadstart"
  , Text
"onmessage"
  , Text
"onmessageerror"
  , Text
"onmousedown"
  , Text
"onmouseenter"
  , Text
"onmouseleave"
  , Text
"onmousemove"
  , Text
"onmouseout"
  , Text
"onmouseover"
  , Text
"onmouseup"
  , Text
"onoffline"
  , Text
"ononline"
  , Text
"onpagehide"
  , Text
"onpageshow"
  , Text
"onpaste"
  , Text
"onpause"
  , Text
"onplay"
  , Text
"onplaying"
  , Text
"onpopstate"
  , Text
"onprogress"
  , Text
"onratechange"
  , Text
"onrejectionhandled"
  , Text
"onreset"
  , Text
"onresize"
  , Text
"onscroll"
  , Text
"onsecuritypolicyviolation"
  , Text
"onseeked"
  , Text
"onseeking"
  , Text
"onselect"
  , Text
"onstalled"
  , Text
"onstorage"
  , Text
"onsubmit"
  , Text
"onsuspend"
  , Text
"ontimeupdate"
  , Text
"ontoggle"
  , Text
"onunhandledrejection"
  , Text
"onunload"
  , Text
"onvolumechange"
  , Text
"onwaiting"
  , Text
"onwheel"
  , Text
"open"
  , Text
"optimum"
  , Text
"pattern"
  , Text
"ping"
  , Text
"placeholder"
  , Text
"playsinline"
  , Text
"poster"
  , Text
"preload"
  , Text
"readonly"
  , Text
"referrerpolicy"
  , Text
"rel"
  , Text
"required"
  , Text
"reversed"
  , Text
"role"
  , Text
"rows"
  , Text
"rowspan"
  , Text
"sandbox"
  , Text
"scope"
  , Text
"selected"
  , Text
"shape"
  , Text
"size"
  , Text
"sizes"
  , Text
"slot"
  , Text
"span"
  , Text
"spellcheck"
  , Text
"src"
  , Text
"srcdoc"
  , Text
"srclang"
  , Text
"srcset"
  , Text
"start"
  , Text
"step"
  , Text
"style"
  , Text
"tabindex"
  , Text
"target"
  , Text
"title"
  , Text
"translate"
  , Text
"type"
  , Text
"typemustmatch"
  , Text
"updateviacache"
  , Text
"usemap"
  , Text
"value"
  , Text
"viewBox"
  , Text
"width"
  , Text
"workertype"
  , Text
"wrap"
  ]


renderHtml :: Html a -> TL.Text
renderHtml :: forall a. 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 :: forall a. Html a -> Builder
toBuilder Html a
HtmlNull = Builder
forall a. Monoid a => a
mempty
toBuilder (HtmlConcat Html a
x 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 Text
t) = Text -> Builder
fromText Text
t
toBuilder (HtmlText Text
t) = Text -> Builder
escapeHtml Text
t
toBuilder (HtmlElement ElementType
eltType Text
tagname Attributes
attrs Maybe (Html a)
mbcontents) =
  Builder
"<" 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 (Text
x,Text
y) = Builder
" " 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 -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escapeHtml Text
y Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\""
    nl' :: Builder
nl' = case ElementType
eltType of
           ElementType
BlockElement -> Builder
"\n"
           ElementType
_            -> Builder
forall a. Monoid a => a
mempty
    filling :: Builder
filling = case Maybe (Html a)
mbcontents of
                 Maybe (Html a)
Nothing   -> Builder
" />"
                 Just Html a
cont -> Builder
">" 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 -> Builder
forall a. Semigroup a => a -> a -> a
<>
                              Text -> Builder
fromText Text
tagname Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"

escapeHtml :: Text -> Builder
escapeHtml :: Text -> Builder
escapeHtml Text
t =
  case Text -> Maybe (Char, Text)
T.uncons Text
post of
    Just (Char
c, 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
    Maybe (Char, Text)
Nothing        -> Text -> Builder
fromText Text
pre
 where
  (Text
pre,Text
post)        = (Char -> Bool) -> Text -> Attribute
T.break Char -> Bool
needsEscaping Text
t
  needsEscaping :: Char -> Bool
needsEscaping Char
'<' = Bool
True
  needsEscaping Char
'>' = Bool
True
  needsEscaping Char
'&' = Bool
True
  needsEscaping Char
'"' = Bool
True
  needsEscaping Char
_   = Bool
False

escapeHtmlChar :: Char -> Builder
escapeHtmlChar :: Char -> Builder
escapeHtmlChar Char
'<' = Builder
"&lt;"
escapeHtmlChar Char
'>' = Builder
"&gt;"
escapeHtmlChar Char
'&' = Builder
"&amp;"
escapeHtmlChar Char
'"' = Builder
"&quot;"
escapeHtmlChar 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 Char
c
  | Char -> Bool
isEscapable Char
c = Char -> Text
T.singleton Char
'%' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02X" (Char -> Int
ord Char
c))
  | Bool
otherwise     = Char -> Text
T.singleton Char
c
  where isEscapable :: Char -> Bool
isEscapable 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` [Char
'%',Char
'/',Char
'?',Char
':',Char
'@',Char
'-',Char
'.',Char
'_',Char
'~',Char
'&',
                                     Char
'#',Char
'!',Char
'$',Char
'\'',Char
'(',Char
')',Char
'*',Char
'+',Char
',',
                                     Char
';',Char
'=']