{-# OPTIONS_HADDOCK hide #-}
module Text.XHtml.Internals where
import Data.Char
import qualified Data.Semigroup as Sem
import qualified Data.Monoid as Mon
infixr 2 +++
infixr 7 <<
infixl 8 !
data HtmlElement
= HtmlString String
| HtmlTag {
HtmlElement -> String
markupTag :: String,
HtmlElement -> [HtmlAttr]
markupAttrs :: [HtmlAttr],
HtmlElement -> Html
markupContent :: Html
}
data HtmlAttr = HtmlAttr String String
htmlAttrPair :: HtmlAttr -> (String,String)
htmlAttrPair :: HtmlAttr -> (String, String)
htmlAttrPair (HtmlAttr String
n String
v) = (String
n,String
v)
newtype Html = Html { Html -> [HtmlElement]
getHtmlElements :: [HtmlElement] }
instance Show Html where
showsPrec :: Int -> Html -> ShowS
showsPrec Int
_ Html
html = String -> ShowS
showString (forall html. HTML html => html -> String
renderHtmlFragment Html
html)
showList :: [Html] -> ShowS
showList [Html]
htmls = 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 a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> ShowS
shows [Html]
htmls)
instance Show HtmlAttr where
showsPrec :: Int -> HtmlAttr -> ShowS
showsPrec Int
_ (HtmlAttr String
str String
val) =
String -> ShowS
showString String
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 String
val
instance Sem.Semigroup Html where
<> :: Html -> Html -> Html
(<>) = forall a b. (HTML a, HTML b) => a -> b -> Html
(+++)
instance Mon.Monoid Html where
mempty :: Html
mempty = Html
noHtml
mappend :: Html -> Html -> Html
mappend = forall a. Semigroup a => a -> a -> a
(Sem.<>)
class HTML a where
toHtml :: a -> Html
toHtmlFromList :: [a] -> Html
toHtmlFromList [a]
xs = [HtmlElement] -> Html
Html (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [HtmlElement]
x | (Html [HtmlElement]
x) <- forall a b. (a -> b) -> [a] -> [b]
map forall a. HTML a => a -> Html
toHtml [a]
xs])
instance HTML Html where
toHtml :: Html -> Html
toHtml Html
a = Html
a
instance HTML Char where
toHtml :: Char -> Html
toHtml Char
a = forall a. HTML a => a -> Html
toHtml [Char
a]
toHtmlFromList :: String -> Html
toHtmlFromList [] = [HtmlElement] -> Html
Html []
toHtmlFromList String
str = [HtmlElement] -> Html
Html [String -> HtmlElement
HtmlString (ShowS
stringToHtmlString String
str)]
instance (HTML a) => HTML [a] where
toHtml :: [a] -> Html
toHtml [a]
xs = forall a. HTML a => [a] -> Html
toHtmlFromList [a]
xs
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
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
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]
htmls) ! :: Html -> [HtmlAttr] -> Html
! [HtmlAttr]
attr = [HtmlElement] -> Html
Html (forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlElement
addAttrs [HtmlElement]
htmls)
where
addAttrs :: HtmlElement -> HtmlElement
addAttrs (html :: HtmlElement
html@(HtmlTag { markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs }) )
= HtmlElement
html { markupAttrs :: [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs forall a. [a] -> [a] -> [a]
++ [HtmlAttr]
attr }
addAttrs HtmlElement
html = HtmlElement
html
instance CHANGEATTRS Html where
changeAttrs :: Html -> ([HtmlAttr] -> [HtmlAttr]) -> Html
changeAttrs (Html [HtmlElement]
htmls) [HtmlAttr] -> [HtmlAttr]
f = [HtmlElement] -> Html
Html (forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlElement
addAttrs [HtmlElement]
htmls)
where
addAttrs :: HtmlElement -> HtmlElement
addAttrs (html :: HtmlElement
html@(HtmlTag { markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs }) )
= HtmlElement
html { markupAttrs :: [HtmlAttr]
markupAttrs = [HtmlAttr] -> [HtmlAttr]
f [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)
concatHtml :: (HTML a) => [a] -> Html
concatHtml :: forall a. HTML a => [a] -> Html
concatHtml [a]
as = [HtmlElement] -> Html
Html (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map (Html -> [HtmlElement]
getHtmlElementsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. HTML a => a -> Html
toHtml) [a]
as))
(+++) :: (HTML a,HTML b) => a -> b -> Html
a
a +++ :: forall a b. (HTML a, HTML b) => a -> b -> Html
+++ b
b = [HtmlElement] -> Html
Html (Html -> [HtmlElement]
getHtmlElements (forall a. HTML a => a -> Html
toHtml a
a) forall a. [a] -> [a] -> [a]
++ Html -> [HtmlElement]
getHtmlElements (forall a. HTML a => a -> Html
toHtml b
b))
noHtml :: Html
noHtml :: Html
noHtml = [HtmlElement] -> Html
Html []
isNoHtml :: Html -> Bool
isNoHtml :: Html -> Bool
isNoHtml (Html [HtmlElement]
xs) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlElement]
xs
tag :: String
-> Html
-> Html
tag :: String -> Html -> Html
tag String
str Html
htmls = [HtmlElement] -> Html
Html [
HtmlTag {
markupTag :: String
markupTag = String
str,
markupAttrs :: [HtmlAttr]
markupAttrs = [],
markupContent :: Html
markupContent = Html
htmls }]
itag :: String -> Html
itag :: String -> Html
itag String
str = String -> Html -> Html
tag String
str Html
noHtml
emptyAttr :: String -> HtmlAttr
emptyAttr :: String -> HtmlAttr
emptyAttr String
s = String -> String -> HtmlAttr
HtmlAttr String
s String
s
intAttr :: String -> Int -> HtmlAttr
intAttr :: String -> Int -> HtmlAttr
intAttr String
s Int
i = String -> String -> HtmlAttr
HtmlAttr String
s (forall a. Show a => a -> String
show Int
i)
strAttr :: String -> String -> HtmlAttr
strAttr :: String -> String -> HtmlAttr
strAttr String
s String
t = String -> String -> HtmlAttr
HtmlAttr String
s (ShowS
stringToHtmlString String
t)
htmlAttr :: String -> Html -> HtmlAttr
htmlAttr :: String -> Html -> HtmlAttr
htmlAttr String
s Html
t = String -> String -> HtmlAttr
HtmlAttr String
s (forall a. Show a => a -> String
show Html
t)
stringToHtmlString :: String -> String
stringToHtmlString :: ShowS
stringToHtmlString = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
fixChar
where
fixChar :: Char -> String
fixChar Char
'<' = String
"<"
fixChar Char
'>' = String
">"
fixChar Char
'&' = String
"&"
fixChar Char
'"' = String
"""
fixChar Char
c | Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
< Int
0x80 = [Char
c]
fixChar Char
c = String
"&#" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Char -> Int
ord Char
c) forall a. [a] -> [a] -> [a]
++ String
";"
primHtml :: String -> Html
primHtml :: String -> Html
primHtml String
x | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x = [HtmlElement] -> Html
Html []
| Bool
otherwise = [HtmlElement] -> Html
Html [String -> HtmlElement
HtmlString String
x]
mkHtml :: HTML html => html -> Html
mkHtml :: forall a. HTML a => a -> Html
mkHtml = (String -> Html -> Html
tag String
"html" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> String -> HtmlAttr
strAttr String
"xmlns" String
"http://www.w3.org/1999/xhtml"] forall a b. HTML a => (Html -> b) -> a -> b
<<)
showHtmlInternal :: HTML html =>
String
-> html -> String
showHtmlInternal :: forall html. HTML html => String -> html -> String
showHtmlInternal String
docType html
theHtml =
String
docType forall a. [a] -> [a] -> [a]
++ forall html. HTML html => html -> String
showHtmlFragment (forall a. HTML a => a -> Html
mkHtml html
theHtml)
renderHtmlInternal :: HTML html =>
String
-> html -> String
renderHtmlInternal :: forall html. HTML html => String -> html -> String
renderHtmlInternal String
docType html
theHtml =
String
docType forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall html. HTML html => html -> String
renderHtmlFragment (forall a. HTML a => a -> Html
mkHtml html
theHtml) forall a. [a] -> [a] -> [a]
++ String
"\n"
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 -> String
showHtmlFragment :: forall html. HTML html => html -> String
showHtmlFragment html
h =
(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 a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> ShowS
showHtml' 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) String
""
renderHtmlFragment :: HTML html => html -> String
renderHtmlFragment :: forall html. HTML html => html -> String
renderHtmlFragment html
h =
(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 a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> HtmlElement -> ShowS
renderHtml' Int
0) 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) String
""
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. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 -> ShowS
showHtml' :: HtmlElement -> ShowS
showHtml' (HtmlString String
str) = forall a. [a] -> [a] -> [a]
(++) String
str
showHtml'(HtmlTag { markupTag :: HtmlElement -> String
markupTag = String
name,
markupContent :: HtmlElement -> Html
markupContent = Html
html,
markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs })
= if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
name [String]
validHtmlITags
then Bool -> String -> [HtmlAttr] -> String -> ShowS
renderTag Bool
True String
name [HtmlAttr]
attrs String
""
else (Bool -> String -> [HtmlAttr] -> String -> ShowS
renderTag Bool
False String
name [HtmlAttr]
attrs String
""
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 a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> ShowS
showHtml' (Html -> [HtmlElement]
getHtmlElements Html
html))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
renderEndTag String
name String
"")
renderHtml' :: Int -> HtmlElement -> ShowS
renderHtml' :: Int -> HtmlElement -> ShowS
renderHtml' Int
_ (HtmlString String
str) = forall a. [a] -> [a] -> [a]
(++) String
str
renderHtml' Int
n (HtmlTag
{ markupTag :: HtmlElement -> String
markupTag = String
name,
markupContent :: HtmlElement -> Html
markupContent = Html
html,
markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs })
= if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
name [String]
validHtmlITags
then Bool -> String -> [HtmlAttr] -> String -> ShowS
renderTag Bool
True String
name [HtmlAttr]
attrs (Int -> String
nl Int
n)
else (Bool -> String -> [HtmlAttr] -> String -> ShowS
renderTag Bool
False String
name [HtmlAttr]
attrs (Int -> String
nl Int
n)
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 a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map (Int -> HtmlElement -> ShowS
renderHtml' (Int
nforall a. Num a => a -> a -> a
+Int
2)) (Html -> [HtmlElement]
getHtmlElements Html
html))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
renderEndTag String
name (Int -> String
nl Int
n))
where
nl :: Int -> String
nl Int
n' = String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n' forall a. Integral a => a -> a -> a
`div` Int
8) Char
'\t'
forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n' forall a. Integral a => a -> a -> a
`mod` Int
8) Char
' '
prettyHtml' :: HtmlElement -> [String]
prettyHtml' :: HtmlElement -> [String]
prettyHtml' (HtmlString String
str) = [String
str]
prettyHtml' (HtmlTag
{ markupTag :: HtmlElement -> String
markupTag = String
name,
markupContent :: HtmlElement -> Html
markupContent = Html
html,
markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs })
= if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
name [String]
validHtmlITags
then
[ShowS
rmNL (Bool -> String -> [HtmlAttr] -> String -> ShowS
renderTag Bool
True String
name [HtmlAttr]
attrs String
"" String
"")]
else
[ShowS
rmNL (Bool -> String -> [HtmlAttr] -> String -> ShowS
renderTag Bool
False String
name [HtmlAttr]
attrs String
"" String
"")] forall a. [a] -> [a] -> [a]
++
[String] -> [String]
shift (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> [String]
prettyHtml' (Html -> [HtmlElement]
getHtmlElements Html
html))) forall a. [a] -> [a] -> [a]
++
[ShowS
rmNL (String -> String -> ShowS
renderEndTag String
name String
"" String
"")]
where
shift :: [String] -> [String]
shift = forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> String
" " forall a. [a] -> [a] -> [a]
++ String
x)
rmNL :: ShowS
rmNL = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
renderTag :: Bool
-> String
-> [HtmlAttr]
-> String
-> ShowS
renderTag :: Bool -> String -> [HtmlAttr] -> String -> ShowS
renderTag Bool
empty String
name [HtmlAttr]
attrs String
nl String
r
= String
"<" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
shownAttrs forall a. [a] -> [a] -> [a]
++ String
nl forall a. [a] -> [a] -> [a]
++ String
close forall a. [a] -> [a] -> [a]
++ String
r
where
close :: String
close = if Bool
empty then String
" />" else String
">"
shownAttrs :: String
shownAttrs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Char
' 'forall a. a -> [a] -> [a]
:HtmlAttr -> String
showPair HtmlAttr
attr | HtmlAttr
attr <- [HtmlAttr]
attrs ]
showPair :: HtmlAttr -> String
showPair :: HtmlAttr -> String
showPair (HtmlAttr String
key String
val)
= String
key forall a. [a] -> [a] -> [a]
++ String
"=\"" forall a. [a] -> [a] -> [a]
++ String
val forall a. [a] -> [a] -> [a]
++ String
"\""
renderEndTag :: String
-> String
-> ShowS
renderEndTag :: String -> String -> ShowS
renderEndTag String
name String
nl String
r = String
"</" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
nl forall a. [a] -> [a] -> [a]
++ String
">" forall a. [a] -> [a] -> [a]
++ String
r
validHtmlITags :: [String]
validHtmlITags :: [String]
validHtmlITags = [
String
"area",
String
"base",
String
"basefont",
String
"br",
String
"col",
String
"frame",
String
"hr",
String
"img",
String
"input",
String
"isindex",
String
"link",
String
"meta",
String
"param"
]