module Language.XmlHtml.XmlWriter where
import Control.Monad.Trans
import Control.Monad.Writer.Strict (WriterT, tell, execWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
void a = a >> return ()
newtype HtmlWriter a = HtmlWriter { getHtml :: WriterT String IO a}
deriving (Monad, MonadWriter String)
liftIO t = HtmlWriter $ lift t
writeString = tell
makeXml = execWriterT . getHtml . printThis
data End
data Par
data Param a b where
Param :: Printable a b => [HtmlAttr] -> a -> Param a b
data Elem a b where
Elem :: Printable a b => String -> a -> Elem a b
data HtmlAttr = Attr String String
instance Show HtmlAttr where
show (Attr a b) = a++"="++b
class Printable a b | a -> b where printThis :: a -> HtmlWriter ()
instance Printable [Char] End where
printThis = writeString
instance Printable (HtmlWriter a) End where
printThis = void
instance Printable a Par => Printable (Elem a Par) End where
printThis (Elem tg msg) = do
writeString $ "<"++tg
printThis msg
writeString $ "</"++tg++">\n"
instance Printable a End => Printable (Elem a End) End where
printThis (Elem tg msg) = do
writeString $ "<"++tg++">\n"
printThis msg
writeString $ "</"++tg++">\n"
instance Printable a Par => Printable (Param a Par) Par where
printThis (Param params msg) = do
printThis $ showMiddle params
printThis msg
instance Printable a End => Printable (Param a End) Par where
printThis (Param params msg) = do
printThis $ showMiddle params++">\n"
printThis msg
showMiddle = concatMap (\x -> " "++show x)
tag tg = printThis . Elem tg