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