{-# 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


-- 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 "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 '<' = "&lt;"
escapeHtmlChar '>' = "&gt;"
escapeHtmlChar '&' = "&amp;"
escapeHtmlChar '"' = "&quot;"
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` ['%','/','?',':','@','-','.','_','~','&',
                                     '#','!','$','\'','(',')','*','+',',',
                                     ';','=']