{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings, FlexibleInstances, BangPatterns, RecordWildCards #-}
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 +++
infixr 7 <<
infixl 8 !
data HtmlElement
= HtmlString !Builder
| HtmlTag {
HtmlElement -> Builder
markupTag :: !Builder,
HtmlElement -> [HtmlAttr] -> [HtmlAttr]
markupAttrs :: [HtmlAttr] -> [HtmlAttr],
HtmlElement -> Html
markupContent :: !Html
}
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
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)
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 #-}
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
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 a) =>
(Html -> b)
-> a
-> 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 #-}
(+++) :: (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 (+++) #-}
noHtml :: Html
noHtml :: Html
noHtml = ([HtmlElement] -> [HtmlElement]) -> Html
Html forall a. a -> a
id
{-# INLINE noHtml #-}
isNoHtml :: Html -> Bool
isNoHtml :: Html -> Bool
isNoHtml (Html [HtmlElement] -> [HtmlElement]
xs) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([HtmlElement] -> [HtmlElement]
xs [])
tag :: Builder
-> Html
-> 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]
:
)
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)
stringToHtmlString :: String -> Builder
stringToHtmlString :: String -> Builder
stringToHtmlString = forall a. BoundedPrim a -> [a] -> Builder
primMapListBounded BoundedPrim Char
charUtf8HtmlEscaped
{-# INLINE stringToHtmlString #-}
{-# 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
$
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
$
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
$
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
$
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded FixedPrim Char
P.char7
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
{-# 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
$
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
$
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
$
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
$
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
$
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
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 #-}
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 #-}
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 #-}
showHtmlInternal :: HTML html =>
Builder
-> 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 #-}
renderHtmlInternal :: HTML html =>
Builder
-> 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 #-}
prettyHtmlInternal :: HTML html =>
String
-> 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)
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 #-}
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 #-}
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
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
renderTag :: Bool
-> Builder
-> [HtmlAttr]
-> Builder
-> 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
"\""
renderEndTag :: Builder
-> Builder
-> 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
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"
]