{-# 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.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 -> Builder
markupTag      :: !Builder,
              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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LText.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString

--
-- * Classes
--

instance Show Html where
      showsPrec :: Int -> Html -> ShowS
showsPrec Int
_ Html
html = String -> ShowS
showString (Builder -> String
builderToString (forall html. HTML html => html -> Builder
renderHtmlFragment Html
html))
      showList :: [Html] -> ShowS
showList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> 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) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              String -> ShowS
showString String
"=" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              forall a. Show a => a -> ShowS
shows (Builder -> String
builderToString Builder
val)

-- | @since 3000.2.2
instance Sem.Semigroup Html where
    <> :: 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 = 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 (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [HtmlElement] -> [HtmlElement]
acc -> Html -> [HtmlElement] -> [HtmlElement]
unHtml (forall a. HTML a => a -> Html
toHtml a
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HtmlElement] -> [HtmlElement]
acc) 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 (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HtmlElement] -> [HtmlElement]
acc) forall a. a -> a
id [Html]
htmls)
      {-# INLINE toHtmlFromList #-}

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

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

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

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

instance HTML LText.Text where
    toHtml :: Text -> Html
toHtml Text
"" = ([HtmlElement] -> [HtmlElement]) -> Html
Html forall a. a -> a
id
    toHtml Text
xs = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (Text -> Builder
lazyTextToHtmlString Text
xs) 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 = (forall a b. (a -> b) -> [a] -> [b]
map a -> b
f ([a] -> [a]
as []) 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 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 = 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 (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, Builder
Html
markupContent :: Html
markupTag :: Builder
markupContent :: HtmlElement -> Html
markupTag :: HtmlElement -> Builder
.. } ->
                    HtmlTag
                        { markupAttrs :: [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([HtmlAttr]
attr forall a. [a] -> [a] -> [a]
++)
                        , Builder
Html
markupContent :: Html
markupTag :: Builder
markupContent :: Html
markupTag :: Builder
..
                        }
                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 (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 :: [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HtmlAttr] -> [HtmlAttr]
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 (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [HtmlElement] -> [HtmlElement]
unHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HTML a => a -> Html
toHtml) 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 (forall a. HTML a => a -> Html
toHtml a
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [HtmlElement] -> [HtmlElement]
unHtml (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 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) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([HtmlElement] -> [HtmlElement]
xs [])

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

-- | Constructs an element with a custom name, and
--   without any children.
itag :: Builder -> Html
itag :: Builder -> Html
itag Builder
str = Builder -> Html -> Html
tag Builder
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 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 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 (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 = 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 =
    forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Ord a => a -> a -> Bool
>  Char
'>' ) BoundedPrim Char
P.charUtf8 forall a b. (a -> b) -> a -> b
$
    forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Char
'<' ) (forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'l',(Char
't',Char
';')))) forall a b. (a -> b) -> a -> b
$              -- &lt;
    forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Char
'>' ) (forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'g',(Char
't',Char
';')))) forall a b. (a -> b) -> a -> b
$              -- &gt;
    forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Char
'&' ) (forall {a}. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char
'&',(Char
'a',(Char
'm',(Char
'p',Char
';'))))) forall a b. (a -> b) -> a -> b
$        -- &amp;
    forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Char
'"' ) (forall {a}.
(Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
fixed6 (Char
'&',(Char
'q',(Char
'u',(Char
'o',(Char
't',Char
';')))))) forall a b. (a -> b) -> a -> b
$  -- &quot;
    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 = forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Char, (Char, (Char, Char)))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
      FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 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 = forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, Char))))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
      FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 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 = forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, (Char, Char)))))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
      FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char7 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 =
  forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (forall a. Ord a => a -> a -> Bool
>  Char -> Word8
c2w Char
'>' ) (forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\DEL') forall a. BoundedPrim a
P.emptyB forall a b. (a -> b) -> a -> b
$ forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded FixedPrim Word8
P.word8) forall a b. (a -> b) -> a -> b
$
  forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'<' ) (forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'l',(Char
't',Char
';')))) forall a b. (a -> b) -> a -> b
$                  -- &lt;
  forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'>' ) (forall {a}. (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char
'&',(Char
'g',(Char
't',Char
';')))) forall a b. (a -> b) -> a -> b
$                  -- &gt;
  forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'&' ) (forall {a}. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char
'&',(Char
'a',(Char
'm',(Char
'p',Char
';'))))) forall a b. (a -> b) -> a -> b
$            -- &amp;
  forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'"' ) (forall {a}.
(Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
fixed6 (Char
'&',(Char
'q',(Char
'u',(Char
'o',(Char
't',Char
';')))))) forall a b. (a -> b) -> a -> b
$      -- &quot;
  forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\'') (forall {a}. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
fixed5 (Char
'&',(Char
'#',(Char
'3',(Char
'9',Char
';'))))) forall a b. (a -> b) -> a -> b
$            -- &#39;
  forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\Word8
c -> Word8
c forall a. Ord a => a -> a -> Bool
>= Char -> Word8
c2w Char
' ' Bool -> Bool -> Bool
|| Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\t' Bool -> Bool -> Bool
|| Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\n' Bool -> Bool -> Bool
|| Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\r')
        (forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded FixedPrim Word8
P.word8) forall a. BoundedPrim a
P.emptyB
  where
  {-# INLINE fixed4 #-}
  fixed4 :: (Char, (Char, (Char, Char))) -> BoundedPrim a
fixed4 (Char, (Char, (Char, Char)))
x = forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Char, (Char, (Char, Char)))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
P.>$<
    FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 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 = forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, Char))))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
P.>$<
    FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 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 = forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, (Char, Char)))))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
P.>$<
    FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
P.>*< FixedPrim Char
P.char8 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x    = ([HtmlElement] -> [HtmlElement]) -> Html
Html forall a. a -> a
id
           | Bool
otherwise = ([HtmlElement] -> [HtmlElement]) -> Html
Html (Builder -> HtmlElement
HtmlString (String -> Builder
stringUtf8 String
x) 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 forall a. a -> [a] -> [a]
:)

{-# INLINE primHtmlNonEmptyBuilder #-}

--
-- * Html Rendering
--

mkHtml :: HTML html => html -> Html
mkHtml :: forall a. HTML a => a -> Html
mkHtml = (Builder -> Html -> Html
tag Builder
"html" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Builder -> Text -> HtmlAttr
strAttr Builder
"xmlns" Text
"http://www.w3.org/1999/xhtml"] 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 forall a. Semigroup a => a -> a -> a
<> forall html. HTML html => html -> Builder
showHtmlFragment (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 forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<> forall html. HTML html => html -> Builder
renderHtmlFragment (forall a. HTML a => a -> Html
mkHtml html
theHtml) 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 forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall html. HTML html => html -> String
prettyHtmlFragment (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 forall a b. (a -> b) -> a -> b
$ Html -> [HtmlElement]
getHtmlElements forall a b. (a -> b) -> a -> b
$ forall a. HTML a => a -> Html
toHtml html
h
  where
    go :: [HtmlElement] -> Builder
go [] = forall a. Monoid a => a
mempty
    go (HtmlElement
x : [HtmlElement]
xs) = HtmlElement -> Builder
showHtml' HtmlElement
x 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 forall a b. (a -> b) -> a -> b
$ Html -> [HtmlElement]
getHtmlElements forall a b. (a -> b) -> a -> b
$ forall a. HTML a => a -> Html
toHtml html
h
  where
    go :: [HtmlElement] -> Builder
go [] = forall a. Monoid a => a
mempty
    go (HtmlElement
x:[HtmlElement]
xs) = Int -> HtmlElement -> Builder
renderHtml' Int
0 HtmlElement
x 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HtmlElement -> [String]
prettyHtml' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [HtmlElement]
getHtmlElements forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Builder
markupTag = Builder
name,
                    markupContent :: HtmlElement -> Html
markupContent = Html
html,
                    markupAttrs :: HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
attrs })
    = if Builder -> Bool
isValidHtmlITag Builder
name Bool -> Bool -> Bool
&& Html -> Bool
isNoHtml Html
html
      then Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
True Builder
name ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
""
      else Bool -> Builder -> [HtmlAttr] -> Builder -> Builder
renderTag Bool
False Builder
name ([HtmlAttr] -> [HtmlAttr]
attrs []) Builder
""
        forall a. Semigroup a => a -> a -> a
<> [HtmlElement] -> Builder
go (Html -> [HtmlElement]
getHtmlElements Html
html)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Builder -> Builder
renderEndTag Builder
name Builder
""
  where
    go :: [HtmlElement] -> Builder
go [] = forall a. Monoid a => a
mempty
    go (HtmlElement
x:[HtmlElement]
xs) = HtmlElement -> Builder
showHtml' HtmlElement
x forall a. Semigroup a => a -> a -> a
<> [HtmlElement] -> Builder
go [HtmlElement]
xs

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

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


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


-- | 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
"<" forall a. Semigroup a => a -> a -> a
<> Builder
name forall a. Semigroup a => a -> a -> a
<> Builder
shownAttrs forall a. Semigroup a => a -> a -> a
<> Builder
nl forall a. Semigroup a => a -> a -> a
<> Builder
close
  where
      close :: Builder
close = if Bool
empty then Builder
" />" else Builder
">"

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

      showPair :: HtmlAttr -> Builder
      showPair :: HtmlAttr -> Builder
showPair (HtmlAttr Builder
key Builder
val)
              = Builder
key forall a. Semigroup a => a -> a -> a
<> Builder
"=\"" forall a. Semigroup a => a -> a -> a
<> Builder
val  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
"</" forall a. Semigroup a => a -> a -> a
<> Builder
name forall a. Semigroup a => a -> a -> a
<> Builder
nl forall a. Semigroup a => a -> a -> a
<> Builder
">"

isValidHtmlITag :: Builder -> Bool
isValidHtmlITag :: Builder -> Bool
isValidHtmlITag Builder
bldr = Builder -> ByteString
toLazyByteString Builder
bldr 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 = 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"
                 ]