{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE OverloadedStrings, FlexibleInstances, BangPatterns, RecordWildCards #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.XHtml.internals
-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of
--                Science and Technology, 1999-2001,
--                (c) Bjorn Bringert, 2004-2006
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Chris Dornan <chris@chrisdornan.com>
-- Stability   :  Stable
-- Portability :  Portable
--
-- Internals of the XHTML combinator library.
-----------------------------------------------------------------------------
module Text.XHtml.Internals
    ( module Text.XHtml.Internals
    , Builder
    ) where

import qualified Data.Text.Lazy as LText
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy.Encoding as LText
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.ByteString.Builder hiding (char7)
import qualified Data.ByteString.Builder.Prim as P
import Data.ByteString.Builder.Prim hiding (intDec, charUtf8)
import Data.ByteString.Internal (c2w)
import qualified Data.Semigroup as Sem
import qualified Data.Monoid as Mon
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Word (Word8)

type LText = LText.Text

infixr 2 +++  -- combining Html
infixr 7 <<   -- nesting Html
infixl 8 !    -- adding optional arguments

--
-- * Data types
--

-- | A important property of Html is that all strings inside the
-- structure are already in Html friendly format.
data HtmlElement
      = HtmlString !Builder
        -- ^ ..just..plain..normal..text... but using &copy; and &amb;, etc.
      | HtmlTag {
              HtmlElement -> ByteString
markupTag      :: !BSL.ByteString,
              HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs    :: [HtmlAttr] -> [HtmlAttr],
              HtmlElement -> Html
markupContent  :: !Html
              }
        -- ^ tag with internal markup

-- | Attributes with name and value.
data HtmlAttr = HtmlAttr !Builder !Builder


htmlAttrPair :: HtmlAttr -> (Builder,Builder)
htmlAttrPair :: HtmlAttr -> (Builder, Builder)
htmlAttrPair (HtmlAttr Builder
n Builder
v) = (Builder
n,Builder
v)


newtype Html = Html { Html -> [HtmlElement] -> [HtmlElement]
unHtml :: [HtmlElement] -> [HtmlElement] }

getHtmlElements :: Html -> [HtmlElement]
getHtmlElements :: Html -> [HtmlElement]
getHtmlElements Html
html = Html -> [HtmlElement] -> [HtmlElement]
unHtml Html
html []

builderToString :: Builder -> String
builderToString :: Builder -> String
builderToString =
    Text -> String
LText.unpack (Text -> String) -> (Builder -> Text) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LText.decodeUtf8 (ByteString -> Text) -> (Builder -> ByteString) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString

lazyByteStringToString :: BSL.ByteString -> String
lazyByteStringToString :: ByteString -> String
lazyByteStringToString =
    Text -> String
LText.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LText.decodeUtf8

--
-- * Classes
--

instance Show Html where
      showsPrec :: Int -> Html -> ShowS
showsPrec Int
_ Html
html = String -> ShowS
showString (Builder -> String
builderToString (Html -> Builder
forall html. HTML html => html -> Builder
renderHtmlFragment Html
html))
      showList :: [Html] -> ShowS
showList = (Html -> ShowS -> ShowS) -> ShowS -> [Html] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (ShowS -> ShowS -> ShowS)
-> (Html -> ShowS) -> Html -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> ShowS
forall a. Show a => a -> ShowS
shows) ShowS
forall a. a -> a
id

instance Show HtmlAttr where
      showsPrec :: Int -> HtmlAttr -> ShowS
showsPrec Int
_ (HtmlAttr Builder
str Builder
val) =
              String -> ShowS
showString (Builder -> String
builderToString Builder
str) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              String -> ShowS
showString String
"=" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              String -> ShowS
forall a. Show a => a -> ShowS
shows (Builder -> String
builderToString Builder
val)

-- | @since 3000.2.2
instance Sem.Semigroup Html where
    <> :: Html -> Html -> Html
(<>) = Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
(+++)
    {-# INLINE (<>) #-}

instance Mon.Monoid Html where
    mempty :: Html
mempty = Html
noHtml
    mappend :: Html -> Html -> Html
mappend = Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
(Sem.<>)
    {-# INLINE mappend #-}

-- | HTML is the class of things that can be validly put
-- inside an HTML tag. So this can be one or more 'Html' elements,
-- or a 'String', for example.
class HTML a where
      toHtml     :: a -> Html
      toHtmlFromList :: [a] -> Html

      toHtmlFromList [a]
xs = ([HtmlElement] -> [HtmlElement]) -> Html
Html ((a
 -> ([HtmlElement] -> [HtmlElement])
 -> [HtmlElement]
 -> [HtmlElement])
-> ([HtmlElement] -> [HtmlElement])
-> [a]
-> [HtmlElement]
-> [HtmlElement]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [HtmlElement] -> [HtmlElement]
acc -> Html -> [HtmlElement] -> [HtmlElement]
unHtml (a -> Html
forall a. HTML a => a -> Html
toHtml a
x) ([HtmlElement] -> [HtmlElement])
-> ([HtmlElement] -> [HtmlElement])
-> [HtmlElement]
-> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HtmlElement] -> [HtmlElement]
acc) [HtmlElement] -> [HtmlElement]
forall a. a -> a
id [a]
xs)

instance HTML Html where
      toHtml :: Html -> Html
toHtml Html
a    = Html
a
      {-# INLINE toHtml #-}
      toHtmlFromList :: [Html] -> Html
toHtmlFromList [Html]
htmls = ([HtmlElement] -> [HtmlElement]) -> Html
Html ((Html
 -> ([HtmlElement] -> [HtmlElement])
 -> [HtmlElement]
 -> [HtmlElement])
-> ([HtmlElement] -> [HtmlElement])
-> [Html]
-> [HtmlElement]
-> [HtmlElement]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Html
x [HtmlElement] -> [HtmlElement]
acc -> Html -> [HtmlElement] -> [HtmlElement]
unHtml Html
x ([HtmlElement] -> [HtmlElement])
-> ([HtmlElement] -> [HtmlElement])
-> [HtmlElement]
-> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HtmlElement] -> [HtmlElement]
acc) [HtmlElement] -> [HtmlElement]
forall a. a -> a
id [Html]
htmls)
      {-# INLINE toHtmlFromList #-}

instance HTML Char where
      toHtml :: Char -> Html
toHtml       Char
a = String -> Html
forall a. HTML a => a -> Html
toHtml [Char
a]
      {-# INLINE toHtml #-}
      toHtmlFromList :: String -> Html
toHtmlFromList []  = ([HtmlElement] -> [HtmlElement]) -> Html
Html [HtmlElement] -> [HtmlElement]
forall a. a -> a
id
      toHtmlFromList String
str = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (String -> Builder
stringToHtmlString String
str) HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
:)
      {-# INLINE toHtmlFromList #-}

instance (HTML a) => HTML [a] where
      toHtml :: [a] -> Html
toHtml = [a] -> Html
forall a. HTML a => [a] -> Html
toHtmlFromList
      {-# INLINE toHtml #-}

instance HTML a => HTML (Maybe a) where
      toHtml :: Maybe a -> Html
toHtml = Html -> (a -> Html) -> Maybe a -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html
noHtml a -> Html
forall a. HTML a => a -> Html
toHtml
      {-# INLINE toHtml #-}

instance HTML Text where
    toHtml :: Text -> Html
toHtml Text
"" = ([HtmlElement] -> [HtmlElement]) -> Html
Html [HtmlElement] -> [HtmlElement]
forall a. a -> a
id
    toHtml Text
xs = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (Text -> Builder
textToHtmlString Text
xs) HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
:)
    {-# INLINE toHtml #-}

instance HTML LText.Text where
    toHtml :: Text -> Html
toHtml Text
"" = ([HtmlElement] -> [HtmlElement]) -> Html
Html [HtmlElement] -> [HtmlElement]
forall a. a -> a
id
    toHtml Text
xs = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (Text -> Builder
lazyTextToHtmlString Text
xs) HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
: )
    {-# INLINE toHtml #-}

instance HTML BSL.ByteString where
    toHtml :: ByteString -> Html
toHtml ByteString
"" = ([HtmlElement] -> [HtmlElement]) -> Html
Html [HtmlElement] -> [HtmlElement]
forall a. a -> a
id
    toHtml ByteString
xs = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (ByteString -> Builder
lazyByteString ByteString
xs) HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
: )
    {-# INLINE toHtml #-}

instance HTML BS.ByteString where
    toHtml :: ByteString -> Html
toHtml ByteString
"" = ([HtmlElement] -> [HtmlElement]) -> Html
Html [HtmlElement] -> [HtmlElement]
forall a. a -> a
id
    toHtml ByteString
xs = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (ByteString -> Builder
byteString ByteString
xs) HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
: )
    {-# INLINE toHtml #-}

mapDlist :: (a -> b) -> ([a] -> [a]) -> [b] -> [b]
mapDlist :: forall a b. (a -> b) -> ([a] -> [a]) -> [b] -> [b]
mapDlist a -> b
f [a] -> [a]
as = ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f ([a] -> [a]
as []) [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++)
{-# INLINE mapDlist #-}

class ADDATTRS a where
      (!) :: a -> [HtmlAttr] -> a

-- | CHANGEATTRS is a more expressive alternative to ADDATTRS
class CHANGEATTRS a where
      changeAttrs :: a -> ([HtmlAttr] -> [HtmlAttr]) -> a

instance (ADDATTRS b) => ADDATTRS (a -> b) where
      a -> b
fn ! :: (a -> b) -> [HtmlAttr] -> a -> b
! [HtmlAttr]
attr        = \ a
arg -> a -> b
fn a
arg b -> [HtmlAttr] -> b
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [HtmlAttr]
attr
      {-# INLINE (!) #-}

instance (CHANGEATTRS b) => CHANGEATTRS (a -> b) where
      changeAttrs :: (a -> b) -> ([HtmlAttr] -> [HtmlAttr]) -> a -> b
changeAttrs a -> b
fn [HtmlAttr] -> [HtmlAttr]
f a
arg = b -> ([HtmlAttr] -> [HtmlAttr]) -> b
forall a. CHANGEATTRS a => a -> ([HtmlAttr] -> [HtmlAttr]) -> a
changeAttrs (a -> b
fn a
arg) [HtmlAttr] -> [HtmlAttr]
f

instance ADDATTRS Html where
    (Html [HtmlElement] -> [HtmlElement]
htmls) ! :: Html -> [HtmlAttr] -> Html
! [HtmlAttr]
attr = ([HtmlElement] -> [HtmlElement]) -> Html
Html ((HtmlElement -> HtmlElement)
-> ([HtmlElement] -> [HtmlElement])
-> [HtmlElement]
-> [HtmlElement]
forall a b. (a -> b) -> ([a] -> [a]) -> [b] -> [b]
mapDlist HtmlElement -> HtmlElement
addAttrs [HtmlElement] -> [HtmlElement]
htmls)
      where
        addAttrs :: HtmlElement -> HtmlElement
addAttrs HtmlElement
html =
            case HtmlElement
html of
                HtmlTag { markupAttrs :: HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs, ByteString
Html
markupTag :: HtmlElement -> ByteString
markupContent :: HtmlElement -> Html
markupTag :: ByteString
markupContent :: Html
.. } ->
                    HtmlTag
                        { markupAttrs :: [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs ([HtmlAttr] -> [HtmlAttr])
-> ([HtmlAttr] -> [HtmlAttr]) -> [HtmlAttr] -> [HtmlAttr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([HtmlAttr]
attr [HtmlAttr] -> [HtmlAttr] -> [HtmlAttr]
forall a. [a] -> [a] -> [a]
++)
                        , ByteString
Html
markupTag :: ByteString
markupContent :: Html
markupTag :: ByteString
markupContent :: Html
..
                        }
                HtmlElement
_ ->
                    HtmlElement
html
    {-# INLINE (!) #-}


instance CHANGEATTRS Html where
      changeAttrs :: Html -> ([HtmlAttr] -> [HtmlAttr]) -> Html
changeAttrs (Html [HtmlElement] -> [HtmlElement]
htmls) [HtmlAttr] -> [HtmlAttr]
f = ([HtmlElement] -> [HtmlElement]) -> Html
Html ((HtmlElement -> HtmlElement)
-> ([HtmlElement] -> [HtmlElement])
-> [HtmlElement]
-> [HtmlElement]
forall a b. (a -> b) -> ([a] -> [a]) -> [b] -> [b]
mapDlist HtmlElement -> HtmlElement
addAttrs [HtmlElement] -> [HtmlElement]
htmls)
        where
              addAttrs :: HtmlElement -> HtmlElement
addAttrs html :: HtmlElement
html@(HtmlTag { markupAttrs :: HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs })
                            = HtmlElement
html { markupAttrs = f . attrs }
              addAttrs HtmlElement
html = HtmlElement
html


--
-- * Html primitives and basic combinators
--

-- | Put something inside an HTML element.
(<<) :: (HTML a) =>
        (Html -> b) -- ^ Parent
     -> a -- ^ Child
     -> b
Html -> b
fn << :: forall a b. HTML a => (Html -> b) -> a -> b
<< a
arg = Html -> b
fn (a -> Html
forall a. HTML a => a -> Html
toHtml a
arg)

{-# SPECIALIZE (<<) :: (Html -> b) -> String -> b #-}
{-# SPECIALIZE (<<) :: (Html -> b) -> Text -> b #-}
{-# SPECIALIZE (<<) :: (Html -> b) -> LText -> b #-}
{-# SPECIALIZE (<<) :: (Html -> b) -> Html -> b #-}
{-# SPECIALIZE (<<) :: (Html -> b) -> [Html] -> b #-}
{-# INLINABLE (<<) #-}

concatHtml :: (HTML a) => [a] -> Html
concatHtml :: forall a. HTML a => [a] -> Html
concatHtml = ([HtmlElement] -> [HtmlElement]) -> Html
Html (([HtmlElement] -> [HtmlElement]) -> Html)
-> ([a] -> [HtmlElement] -> [HtmlElement]) -> [a] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
 -> ([HtmlElement] -> [HtmlElement])
 -> [HtmlElement]
 -> [HtmlElement])
-> ([HtmlElement] -> [HtmlElement])
-> [a]
-> [HtmlElement]
-> [HtmlElement]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([HtmlElement] -> [HtmlElement])
-> ([HtmlElement] -> [HtmlElement])
-> [HtmlElement]
-> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (([HtmlElement] -> [HtmlElement])
 -> ([HtmlElement] -> [HtmlElement])
 -> [HtmlElement]
 -> [HtmlElement])
-> (a -> [HtmlElement] -> [HtmlElement])
-> a
-> ([HtmlElement] -> [HtmlElement])
-> [HtmlElement]
-> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [HtmlElement] -> [HtmlElement]
unHtml (Html -> [HtmlElement] -> [HtmlElement])
-> (a -> Html) -> a -> [HtmlElement] -> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Html
forall a. HTML a => a -> Html
toHtml) [HtmlElement] -> [HtmlElement]
forall a. a -> a
id

{-# SPECIALIZE concatHtml :: [Html] -> Html #-}
{-# INLINABLE concatHtml #-}

-- | Create a piece of HTML which is the concatenation
--   of two things which can be made into HTML.
(+++) :: (HTML a, HTML b) => a -> b -> Html
a
a +++ :: forall a b. (HTML a, HTML b) => a -> b -> Html
+++ b
b = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Html -> [HtmlElement] -> [HtmlElement]
unHtml (a -> Html
forall a. HTML a => a -> Html
toHtml a
a) ([HtmlElement] -> [HtmlElement])
-> ([HtmlElement] -> [HtmlElement])
-> [HtmlElement]
-> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [HtmlElement] -> [HtmlElement]
unHtml (b -> Html
forall a. HTML a => a -> Html
toHtml b
b))

{-# SPECIALIZE (+++) :: Html -> Html -> Html #-}
{-# INLINABLE (+++) #-}

-- | An empty piece of HTML.
noHtml :: Html
noHtml :: Html
noHtml = ([HtmlElement] -> [HtmlElement]) -> Html
Html [HtmlElement] -> [HtmlElement]
forall a. a -> a
id

{-# INLINE noHtml #-}

-- | Checks whether the given piece of HTML is empty. This materializes the
-- list, so it's not great to do this a bunch.
isNoHtml :: Html -> Bool
isNoHtml :: Html -> Bool
isNoHtml (Html [HtmlElement] -> [HtmlElement]
xs) = [HtmlElement] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([HtmlElement] -> [HtmlElement]
xs [])

-- | Constructs an element with a custom name.
tag :: BSL.ByteString -- ^ Element name
    -> Html -- ^ Element contents
    -> Html
tag :: ByteString -> Html -> Html
tag ByteString
str Html
htmls =
    ([HtmlElement] -> [HtmlElement]) -> Html
Html
        (
        HtmlTag
            { markupTag :: ByteString
markupTag = ByteString
str
            , markupAttrs :: [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
forall a. a -> a
id
            , markupContent :: Html
markupContent = Html
htmls
            }
        HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
:
        )

-- | Constructs an element with a custom name, and
--   without any children.
itag :: BSL.ByteString -> Html
itag :: ByteString -> Html
itag ByteString
str = ByteString -> Html -> Html
tag ByteString
str Html
noHtml

emptyAttr :: Builder -> HtmlAttr
emptyAttr :: Builder -> HtmlAttr
emptyAttr Builder
s = Builder -> Builder -> HtmlAttr
HtmlAttr Builder
s Builder
s

intAttr :: Builder -> Int -> HtmlAttr
intAttr :: Builder -> Int -> HtmlAttr
intAttr Builder
s = Builder -> Builder -> HtmlAttr
HtmlAttr Builder
s (Builder -> HtmlAttr) -> (Int -> Builder) -> Int -> HtmlAttr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder
intDec
{-# INLINE intAttr #-}

strAttr :: Builder -> LText.Text -> HtmlAttr
strAttr :: Builder -> Text -> HtmlAttr
strAttr Builder
s = Builder -> Builder -> HtmlAttr
HtmlAttr Builder
s (Builder -> HtmlAttr) -> (Text -> Builder) -> Text -> HtmlAttr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
lazyTextToHtmlString
{-# INLINE strAttr #-}

htmlAttr :: Builder -> Html -> HtmlAttr
htmlAttr :: Builder -> Html -> HtmlAttr
htmlAttr Builder
s Html
t = Builder -> Builder -> HtmlAttr
HtmlAttr Builder
s (Html -> Builder
forall html. HTML html => html -> Builder
renderHtmlFragment Html
t)

{-
foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
      -> (String -> a)
      -> Html
      -> a
foldHtml f g (HtmlTag str attr fmls)
      = f str attr (map (foldHtml f g) fmls)
foldHtml f g (HtmlString  str)
      = g str

-}

-- | Processing Strings into Html friendly things.
stringToHtmlString :: String -> Builder
stringToHtmlString :: String -> Builder
stringToHtmlString = BoundedPrim Char -> String -> Builder
forall a. BoundedPrim a -> [a] -> Builder
primMapListBounded BoundedPrim Char
charUtf8HtmlEscaped
{-# INLINE stringToHtmlString #-}

-- | Copied from @blaze-builder@
{-# INLINE charUtf8HtmlEscaped #-}
charUtf8HtmlEscaped :: BoundedPrim Char
charUtf8HtmlEscaped :: BoundedPrim Char
charUtf8HtmlEscaped =
    (Char -> Bool)
-> BoundedPrim Char -> BoundedPrim Char -> BoundedPrim Char
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>  Char
'>' ) BoundedPrim Char
P.charUtf8 (BoundedPrim Char -> BoundedPrim Char)
-> BoundedPrim Char -> BoundedPrim Char
forall a b. (a -> b) -> a -> b
$
    (Char -> Bool)
-> BoundedPrim Char -> BoundedPrim Char -> BoundedPrim Char
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' ) ((Char, (Char, (Char, Char))) -> BoundedPrim Char
forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'l',(Char
't',Char
';')))) (BoundedPrim Char -> BoundedPrim Char)
-> BoundedPrim Char -> BoundedPrim Char
forall a b. (a -> b) -> a -> b
$              -- &lt;
    (Char -> Bool)
-> BoundedPrim Char -> BoundedPrim Char -> BoundedPrim Char
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' ) ((Char, (Char, (Char, Char))) -> BoundedPrim Char
forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'g',(Char
't',Char
';')))) (BoundedPrim Char -> BoundedPrim Char)
-> BoundedPrim Char -> BoundedPrim Char
forall a b. (a -> b) -> a -> b
$              -- &gt;
    (Char -> Bool)
-> BoundedPrim Char -> BoundedPrim Char -> BoundedPrim Char
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'&' ) ((Char, (Char, (Char, (Char, Char)))) -> BoundedPrim Char
forall {a}. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char
'&',(Char
'a',(Char
'm',(Char
'p',Char
';'))))) (BoundedPrim Char -> BoundedPrim Char)
-> BoundedPrim Char -> BoundedPrim Char
forall a b. (a -> b) -> a -> b
$        -- &amp;
    (Char -> Bool)
-> BoundedPrim Char -> BoundedPrim Char -> BoundedPrim Char
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' ) ((Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim Char
forall {a}.
(Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
fixed6 (Char
'&',(Char
'q',(Char
'u',(Char
'o',(Char
't',Char
';')))))) (BoundedPrim Char -> BoundedPrim Char)
-> BoundedPrim Char -> BoundedPrim Char
forall a b. (a -> b) -> a -> b
$  -- &quot;
    FixedPrim Char -> BoundedPrim Char
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded FixedPrim Char
P.char7 -- fallback for Chars smaller than '>'
  where
    {-# INLINE fixed4 #-}
    fixed4 :: (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char, (Char, (Char, Char)))
x = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, Char))) -> a -> (Char, (Char, (Char, Char)))
forall a b. a -> b -> a
const (Char, (Char, (Char, Char)))
x (a -> (Char, (Char, (Char, Char))))
-> FixedPrim (Char, (Char, (Char, Char))) -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
      FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7

    {-# INLINE fixed5 #-}
    fixed5 :: (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char, (Char, (Char, (Char, Char))))
x = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, (Char, Char))))
-> a -> (Char, (Char, (Char, (Char, Char))))
forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, Char))))
x (a -> (Char, (Char, (Char, (Char, Char)))))
-> FixedPrim (Char, (Char, (Char, (Char, Char)))) -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
      FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, Char)))
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7

    {-# INLINE fixed6 #-}
    fixed6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
fixed6 (Char, (Char, (Char, (Char, (Char, Char)))))
x = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, (Char, (Char, Char)))))
-> a -> (Char, (Char, (Char, (Char, (Char, Char)))))
forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, (Char, Char)))))
x (a -> (Char, (Char, (Char, (Char, (Char, Char))))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
-> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
      FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, Char)))
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7

textToHtmlString :: Text -> Builder
textToHtmlString :: Text -> Builder
textToHtmlString = BoundedPrim Word8 -> Text -> Builder
Text.encodeUtf8BuilderEscaped BoundedPrim Word8
wordHtmlEscaped
{-# INLINE textToHtmlString #-}

lazyTextToHtmlString :: LText.Text -> Builder
lazyTextToHtmlString :: Text -> Builder
lazyTextToHtmlString = BoundedPrim Word8 -> Text -> Builder
LText.encodeUtf8BuilderEscaped BoundedPrim Word8
wordHtmlEscaped

-- | Copied from @blaze-builder@
{-# INLINE wordHtmlEscaped #-}
wordHtmlEscaped :: P.BoundedPrim Word8
wordHtmlEscaped :: BoundedPrim Word8
wordHtmlEscaped =
  (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>  Char -> Word8
c2w Char
'>' ) ((Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\DEL') BoundedPrim Word8
forall a. BoundedPrim a
P.emptyB (BoundedPrim Word8 -> BoundedPrim Word8)
-> BoundedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$ FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded FixedPrim Word8
P.word8) (BoundedPrim Word8 -> BoundedPrim Word8)
-> BoundedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$
  (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'<' ) ((Char, (Char, (Char, Char))) -> BoundedPrim Word8
forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'l',(Char
't',Char
';')))) (BoundedPrim Word8 -> BoundedPrim Word8)
-> BoundedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$                  -- &lt;
  (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'>' ) ((Char, (Char, (Char, Char))) -> BoundedPrim Word8
forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'g',(Char
't',Char
';')))) (BoundedPrim Word8 -> BoundedPrim Word8)
-> BoundedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$                  -- &gt;
  (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'&' ) ((Char, (Char, (Char, (Char, Char)))) -> BoundedPrim Word8
forall {a}. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char
'&',(Char
'a',(Char
'm',(Char
'p',Char
';'))))) (BoundedPrim Word8 -> BoundedPrim Word8)
-> BoundedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$            -- &amp;
  (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'"' ) ((Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim Word8
forall {a}.
(Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
fixed6 (Char
'&',(Char
'q',(Char
'u',(Char
'o',(Char
't',Char
';')))))) (BoundedPrim Word8 -> BoundedPrim Word8)
-> BoundedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$      -- &quot;
  (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\'') ((Char, (Char, (Char, (Char, Char)))) -> BoundedPrim Word8
forall {a}. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char
'&',(Char
'#',(Char
'3',(Char
'9',Char
';'))))) (BoundedPrim Word8 -> BoundedPrim Word8)
-> BoundedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$            -- &#39;
  (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\Word8
c -> Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Word8
c2w Char
' ' Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\t' Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\n' Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\r')
        (FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded FixedPrim Word8
P.word8) BoundedPrim Word8
forall a. BoundedPrim a
P.emptyB
  where
  {-# INLINE fixed4 #-}
  fixed4 :: (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char, (Char, (Char, Char)))
x = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, Char))) -> a -> (Char, (Char, (Char, Char)))
forall a b. a -> b -> a
const (Char, (Char, (Char, Char)))
x (a -> (Char, (Char, (Char, Char))))
-> FixedPrim (Char, (Char, (Char, Char))) -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
P.>$<
    FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8
  {-# INLINE fixed5 #-}
  fixed5 :: (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char, (Char, (Char, (Char, Char))))
x = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, (Char, Char))))
-> a -> (Char, (Char, (Char, (Char, Char))))
forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, Char))))
x (a -> (Char, (Char, (Char, (Char, Char)))))
-> FixedPrim (Char, (Char, (Char, (Char, Char)))) -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
P.>$<
    FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, Char)))
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8
  {-# INLINE fixed6 #-}
  fixed6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
fixed6 (Char, (Char, (Char, (Char, (Char, Char)))))
x = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, (Char, (Char, Char)))))
-> a -> (Char, (Char, (Char, (Char, (Char, Char)))))
forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, (Char, Char)))))
x (a -> (Char, (Char, (Char, (Char, (Char, Char))))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
-> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
P.>$<
    FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, Char)))
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8

-- | This is not processed for special chars.
-- use stringToHtml or lineToHtml instead, for user strings,
-- because they understand special chars, like @'<'@.
primHtml :: String -> Html
primHtml :: String -> Html
primHtml String
x | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x    = ([HtmlElement] -> [HtmlElement]) -> Html
Html [HtmlElement] -> [HtmlElement]
forall a. a -> a
id
           | Bool
otherwise = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (String -> Builder
stringUtf8 String
x) HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
:)

{-# INLINE primHtml #-}

-- | Does not process special characters, or check to see if it is empty.
primHtmlNonEmptyBuilder :: Builder -> Html
primHtmlNonEmptyBuilder :: Builder -> Html
primHtmlNonEmptyBuilder Builder
x = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString Builder
x HtmlElement -> [HtmlElement] -> [HtmlElement]
forall a. a -> [a] -> [a]
:)

{-# INLINE primHtmlNonEmptyBuilder #-}

--
-- * Html Rendering
--

mkHtml :: HTML html => html -> Html
mkHtml :: forall a. HTML a => a -> Html
mkHtml = (ByteString -> Html -> Html
tag ByteString
"html" (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Builder -> Text -> HtmlAttr
strAttr Builder
"xmlns" Text
"http://www.w3.org/1999/xhtml"] (Html -> Html) -> html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<)

{-# SPECIALIZE mkHtml :: Html -> Html #-}
{-# INLINABLE mkHtml #-}

-- | Output the HTML without adding newlines or spaces within the markup.
--   This should be the most time and space efficient way to
--   render HTML, though the output is quite unreadable.
showHtmlInternal :: HTML html =>
                    Builder -- ^ DOCTYPE declaration
                 -> html -> Builder
showHtmlInternal :: forall html. HTML html => Builder -> html -> Builder
showHtmlInternal Builder
docType html
theHtml =
    Builder
docType Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Html -> Builder
forall html. HTML html => html -> Builder
showHtmlFragment (html -> Html
forall a. HTML a => a -> Html
mkHtml html
theHtml)

{-# SPECIALIZE showHtmlInternal :: Builder -> Html -> Builder #-}
{-# INLINABLE showHtmlInternal #-}


-- | Outputs indented HTML. Because space matters in
--   HTML, the output is quite messy.
renderHtmlInternal :: HTML html =>
                      Builder  -- ^ DOCTYPE declaration
                   -> html -> Builder
renderHtmlInternal :: forall html. HTML html => Builder -> html -> Builder
renderHtmlInternal Builder
docType html
theHtml =
      Builder
docType Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Html -> Builder
forall html. HTML html => html -> Builder
renderHtmlFragment (html -> Html
forall a. HTML a => a -> Html
mkHtml html
theHtml) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

{-# SPECIALIZE renderHtmlInternal :: Builder -> Html -> Builder #-}
{-# INLINABLE renderHtmlInternal #-}

-- | Outputs indented HTML, with indentation inside elements.
--   This can change the meaning of the HTML document, and
--   is mostly useful for debugging the HTML output.
--   The implementation is inefficient, and you are normally
--   better off using 'showHtml' or 'renderHtml'.
prettyHtmlInternal :: HTML html =>
                      String -- ^ DOCTYPE declaration
                   -> html -> String
prettyHtmlInternal :: forall html. HTML html => String -> html -> String
prettyHtmlInternal String
docType html
theHtml =
    String
docType String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Html -> String
forall html. HTML html => html -> String
prettyHtmlFragment (html -> Html
forall a. HTML a => a -> Html
mkHtml html
theHtml)

-- | Render a piece of HTML without adding a DOCTYPE declaration
--   or root element. Does not add any extra whitespace.
showHtmlFragment :: HTML html => html -> Builder
showHtmlFragment :: forall html. HTML html => html -> Builder
showHtmlFragment html
h =
    [HtmlElement] -> Builder
go ([HtmlElement] -> Builder) -> [HtmlElement] -> Builder
forall a b. (a -> b) -> a -> b
$ Html -> [HtmlElement]
getHtmlElements (Html -> [HtmlElement]) -> Html -> [HtmlElement]
forall a b. (a -> b) -> a -> b
$ html -> Html
forall a. HTML a => a -> Html
toHtml html
h
  where
    go :: [HtmlElement] -> Builder
go [] = Builder
forall a. Monoid a => a
mempty
    go (HtmlElement
x : [HtmlElement]
xs) = HtmlElement -> Builder
showHtml' HtmlElement
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [HtmlElement] -> Builder
go [HtmlElement]
xs

{-# SPECIALIZE showHtmlFragment :: Html -> Builder #-}
{-# INLINABLE showHtmlFragment #-}

-- | Render a piece of indented HTML without adding a DOCTYPE declaration
--   or root element. Only adds whitespace where it does not change
--   the meaning of the document.
renderHtmlFragment :: HTML html => html -> Builder
renderHtmlFragment :: forall html. HTML html => html -> Builder
renderHtmlFragment html
h =
    [HtmlElement] -> Builder
go ([HtmlElement] -> Builder) -> [HtmlElement] -> Builder
forall a b. (a -> b) -> a -> b
$ Html -> [HtmlElement]
getHtmlElements (Html -> [HtmlElement]) -> Html -> [HtmlElement]
forall a b. (a -> b) -> a -> b
$ html -> Html
forall a. HTML a => a -> Html
toHtml html
h
  where
    go :: [HtmlElement] -> Builder
go [] = Builder
forall a. Monoid a => a
mempty
    go (HtmlElement
x:[HtmlElement]
xs) = Int -> HtmlElement -> Builder
renderHtml' Int
0 HtmlElement
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [HtmlElement] -> Builder
go [HtmlElement]
xs

{-# SPECIALIZE renderHtmlFragment :: Html -> Builder #-}
{-# INLINABLE renderHtmlFragment #-}

-- | Render a piece of indented HTML without adding a DOCTYPE declaration
--   or a root element.
--   The indentation is done inside elements.
--   This can change the meaning of the HTML document, and
--   is mostly useful for debugging the HTML output.
--   The implementation is inefficient, and you are normally
--   better off using 'showHtmlFragment' or 'renderHtmlFragment'.
prettyHtmlFragment :: HTML html => html -> String
prettyHtmlFragment :: forall html. HTML html => html -> String
prettyHtmlFragment =
    [String] -> String
unlines ([String] -> String) -> (html -> [String]) -> html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HtmlElement -> [String]) -> [HtmlElement] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HtmlElement -> [String]
prettyHtml' ([HtmlElement] -> [String])
-> (html -> [HtmlElement]) -> html -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [HtmlElement]
getHtmlElements (Html -> [HtmlElement]) -> (html -> Html) -> html -> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. html -> Html
forall a. HTML a => a -> Html
toHtml

-- | Show a single HTML element, without adding whitespace.
showHtml' :: HtmlElement -> Builder
showHtml' :: HtmlElement -> Builder
showHtml' (HtmlString Builder
str) = Builder
str
showHtml'(HtmlTag { markupTag :: HtmlElement -> ByteString
markupTag = ByteString
name,
                    markupContent :: HtmlElement -> Html
markupContent = Html
html,
                    markupAttrs :: HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs })
    = if ByteString -> Bool
isValidHtmlITag ByteString
name Bool -> Bool -> Bool
&& Html -> Bool
isNoHtml Html
html
      then Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
True Builder
nameBuilder ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
""
      else Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
False Builder
nameBuilder ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
""
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [HtmlElement] -> Builder
go (Html -> [HtmlElement]
getHtmlElements Html
html)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder -> Builder
renderEndTag Builder
nameBuilder Builder
""
  where
    go :: [HtmlElement] -> Builder
go [] = Builder
forall a. Monoid a => a
mempty
    go (HtmlElement
x:[HtmlElement]
xs) = HtmlElement -> Builder
showHtml' HtmlElement
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [HtmlElement] -> Builder
go [HtmlElement]
xs

    nameBuilder :: Builder
    nameBuilder :: Builder
nameBuilder = ByteString -> Builder
lazyByteString ByteString
name

renderHtml' :: Int -> HtmlElement -> Builder
renderHtml' :: Int -> HtmlElement -> Builder
renderHtml' Int
_ (HtmlString Builder
str) = Builder
str
renderHtml' Int
n (HtmlTag
              { markupTag :: HtmlElement -> ByteString
markupTag = ByteString
name,
                markupContent :: HtmlElement -> Html
markupContent = Html
html,
                markupAttrs :: HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs })
      = if ByteString -> Bool
isValidHtmlITag ByteString
name Bool -> Bool -> Bool
&& Html -> Bool
isNoHtml Html
html
        then Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
True Builder
nameBuilder ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
nl
        else Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
False Builder
nameBuilder ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
nl
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (HtmlElement -> Builder) -> [HtmlElement] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> HtmlElement -> Builder
renderHtml' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) (Html -> [HtmlElement]
getHtmlElements Html
html)
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder -> Builder
renderEndTag Builder
nameBuilder Builder
nl
    where
      nl :: Builder
      nl :: Builder
nl = Char -> Builder
charUtf8 Char
'\n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tabs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
spaces

      tabs :: Builder
      tabs :: Builder
tabs =
        case Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 of
          Int
m | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> Builder
forall a. Monoid a => a
mempty
          Int
m          -> Int -> Builder -> Builder
forall b. Integral b => b -> Builder -> Builder
forall a b. (Semigroup a, Integral b) => b -> a -> a
Sem.stimes Int
m (Char -> Builder
charUtf8 Char
'\t')

      spaces :: Builder
      spaces :: Builder
spaces =
        case Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 of
          Int
m | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> Builder
forall a. Monoid a => a
mempty
          Int
m          -> Int -> Builder -> Builder
forall b. Integral b => b -> Builder -> Builder
forall a b. (Semigroup a, Integral b) => b -> a -> a
Sem.stimes Int
m (Char -> Builder
charUtf8 Char
' ')

      nameBuilder :: Builder
      nameBuilder :: Builder
nameBuilder = ByteString -> Builder
lazyByteString ByteString
name


prettyHtml' :: HtmlElement -> [String]
prettyHtml' :: HtmlElement -> [String]
prettyHtml' (HtmlString Builder
str) = [Builder -> String
builderToString Builder
str]
prettyHtml' (HtmlTag
              { markupTag :: HtmlElement -> ByteString
markupTag = ByteString
name,
                markupContent :: HtmlElement -> Html
markupContent = Html
html,
                markupAttrs :: HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs })
      = if ByteString -> Bool
isValidHtmlITag ByteString
name Bool -> Bool -> Bool
&& Html -> Bool
isNoHtml Html
html
        then
         [Builder -> String
rmNL (Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
True Builder
nameBuilder ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
"")]
        else
         [Builder -> String
rmNL (Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
False Builder
nameBuilder ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
"")] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
          [String] -> [String]
shift ((HtmlElement -> [String]) -> [HtmlElement] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HtmlElement -> [String]
prettyHtml' (Html -> [HtmlElement]
getHtmlElements Html
html)) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         [Builder -> String
rmNL (Builder -> Builder -> Builder
renderEndTag Builder
nameBuilder Builder
"")]
  where
      shift :: [String] -> [String]
shift = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"   " String -> ShowS
forall a. [a] -> [a] -> [a]
++)
      rmNL :: Builder -> String
rmNL = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ShowS -> (Builder -> String) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> String
builderToString

      nameBuilder :: Builder
      nameBuilder :: Builder
nameBuilder = ByteString -> Builder
lazyByteString ByteString
name


-- | Show a start tag
renderTag :: Bool       -- ^ 'True' if the empty tag shorthand should be used
          -> Builder    -- ^ Tag name
          -> [HtmlAttr] -- ^ Attributes
          -> Builder    -- ^ Whitespace to add after attributes
          -> Builder
renderTag :: Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
empty Builder
name [HtmlAttr]
attrs Builder
nl
      = Builder
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
shownAttrs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nl Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
close
  where
      close :: Builder
close = if Bool
empty then Builder
" />" else Builder
">"

      shownAttrs :: Builder
shownAttrs = (HtmlAttr -> Builder -> Builder)
-> Builder -> [HtmlAttr] -> Builder
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\HtmlAttr
attr Builder
acc -> Char -> Builder
charUtf8 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> HtmlAttr -> Builder
showPair HtmlAttr
attr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
acc) Builder
forall a. Monoid a => a
mempty [HtmlAttr]
attrs

      showPair :: HtmlAttr -> Builder
      showPair :: HtmlAttr -> Builder
showPair (HtmlAttr Builder
key Builder
val)
              = Builder
key Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"=\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
val  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\""

-- | Show an end tag
renderEndTag :: Builder -- ^ Tag name
             -> Builder -- ^ Whitespace to add after tag name
             -> Builder
renderEndTag :: Builder -> Builder -> Builder
renderEndTag Builder
name Builder
nl = Builder
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nl Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"

isValidHtmlITag :: BSL.ByteString -> Bool
isValidHtmlITag :: ByteString -> Bool
isValidHtmlITag ByteString
bs = ByteString
bs ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ByteString
validHtmlITags

-- | The names of all elements which can be represented using the empty tag
--   short-hand.
validHtmlITags :: Set BSL.ByteString
validHtmlITags :: Set ByteString
validHtmlITags = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList [
                  ByteString
"area",
                  ByteString
"base",
                  ByteString
"basefont",
                  ByteString
"br",
                  ByteString
"col",
                  ByteString
"frame",
                  ByteString
"hr",
                  ByteString
"img",
                  ByteString
"input",
                  ByteString
"isindex",
                  ByteString
"link",
                  ByteString
"meta",
                  ByteString
"param"
                 ]