module Control.Monad.Takahashi.HtmlBuilder.Html
( Html(..)
, showHtml
, showDiv
) where
import Control.Monad.Takahashi.HtmlBuilder.Style
import Data.Monoid
import Data.List (intercalate, lines)
data Html
= H1 String Html
| H2 String Html
| H3 String Html
| Li [String] Html
| P String Html
| TT String Html
| Img String Style Html
| Div
(Maybe String)
(Maybe String)
(Maybe Style)
Html
Html
| Emp
deriving (Show, Read, Eq, Ord)
instance Monoid Html where
mempty = Emp
(H1 s h) `mappend` i = H1 s (h `mappend` i)
(H2 s h) `mappend` i = H2 s (h `mappend` i)
(H3 s h) `mappend` i = H3 s (h `mappend` i)
(Li xs h) `mappend` i = Li xs (h `mappend` i)
(P s h) `mappend` i = P s (h `mappend` i)
(TT s h) `mappend` i = TT s (h `mappend` i)
(Img fp s h) `mappend` i = Img fp s (h `mappend` i)
(Div cls name style con h) `mappend` i = Div cls name style con (h `mappend` i)
Emp `mappend` i = i
showHtml :: Html -> String
showHtml = intercalate "<br />". lines . showHtml'
where
showHtml' :: Html -> String
showHtml' (H1 s h) = concat ["<h1>", s, "</h1>", showHtml h]
showHtml' (H2 s h) = concat ["<h2>", s, "</h2>", showHtml h]
showHtml' (H3 s h) = concat ["<h3>", s, "</h3>", showHtml h]
showHtml' (Li xs h) = concat ["<ul>", concatMap (\s -> "<li>" ++ s ++ "</li>") xs, "</ul>", showHtml h]
showHtml' (P s h) = concat ["<p>", s, "</p>", showHtml h]
showHtml' (TT s h) = concat ["<tt>", s, "</tt>", showHtml h]
showHtml' img@(Img _ _ h) = concat ["<img ", showImg img ,"/>", showHtml h]
showHtml' div@(Div _ _ _ s h) = concat ["<div ", showDiv div,">", showHtml s, "</div>", showHtml h]
showHtml' Emp = ""
showDiv :: Html -> String
showDiv (Div cls name style _ _) = intercalate " " $ filter (/="") [classStr, nameStr, styleStr]
where
classStr = maybe "" (\x -> "class=\"" ++ x ++ "\"") cls
nameStr = maybe "" (\x -> "name=\"" ++ x ++ "\"") name
styleStr = showStyleStr style
showDiv _ = ""
showImg :: Html -> String
showImg (Img fp style _) = intercalate " " $ filter (/="") ["src=\"" ++ fp ++ "\"", styleStr]
where
styleStr = showStyleStr $ Just style
showStyleStr :: Maybe Style -> String
showStyleStr style = maybe "" (\x -> "style=\"" ++ showStyle x ++ "\"") style