{-- Xhtml1 - Haskell Combinator for XHTML 1.0 Strict/Trnsitional version : 2002-02-21 Author : Ahn Ki-yung Tested under Hugs version December 2001. Not tested under GHC, but I bet this works. --} module Xhtml1 where import Char infixr 2 +++ -- combining Content infixr 7 << -- nesting Content infixl 8 ! -- adding optional arguments infix 2 -= -- attribute paring (<<) = ($) (-=) = Attr data Attr = Attr String String instance Show Attr where show (Attr n s) = n++"=\""++s++"\"" data TagData = XmlStr String | Tag Int String [Attr] Content | ITag Int String [Attr] instance Show TagData where show (XmlStr s) = s show (ITag n s attrs) = '<':s++ show_list_by show " " attrs ++" />\n" ++ replicate n '\t' show (t@(Tag n s attrs x)) | s=="pre" || s=="a" = showNnl t | otherwise = '<':s++ show_list_by show " " attrs ++">\n" ++ replicate n' '\t' ++ show (indent x) ++ '\n': replicate n '\t' ++ "\n" ++ replicate n '\t' where indent (Content xs) = Content $ map inclv xs inclv (Tag _ s attrs x) = Tag n' s attrs x inclv (ITag _ s attrs) = ITag n' s attrs inclv x = x n' = succ n class ShowNnl a where showNnl :: a -> String instance ShowNnl Attr where showNnl = show instance ShowNnl Content where showNnl (Content []) = "" showNnl (Content (td:tds)) = showNnl td ++ showNnl (Content tds) instance ShowNnl TagData where showNnl (XmlStr s) = s showNnl (ITag _ s attrs) = '<':s++ show_list_by showNnl " " attrs ++" />" showNnl (Tag _ s attrs x) = '<':s++ show_list_by showNnl " " attrs ++">" ++ showNnl x ++ "" show_list_by _ sd [] = "" show_list_by f sd (x:xs) = ' ':f x ++ show_list_by f sd xs data Content = Content {contentlist::[TagData]} instance Show Content where show (Content []) = "" show (Content (td:tds)) = show td ++ show (Content tds) class CONTENT a where toContent :: a -> Content list2Content :: [a] -> Content list2Content xs = Content (concat [ x | (Content x) <- map toContent xs]) tag st attrs x = Content [Tag 0 st attrs $ toContent x] itag st attrs = Content [ITag 0 st attrs] instance CONTENT Content where toContent = id instance CONTENT Char where toContent c = Content [XmlStr $ fixChar c] instance CONTENT a => CONTENT [a] where toContent = list2Content data CDATA = CDATA String instance CONTENT CDATA where toContent (CDATA s) = Content [XmlStr s] toCDATA = CDATA . concatMap fixChar fixChar '<' = "<" fixChar '>' = ">" fixChar '&' = "&" fixChar '"' = """ fixChar c = [c] concatContent :: (CONTENT a) => [a] -> Content concatContent cs = Content (concat (map (contentlist . toContent) cs)) (+++) :: (CONTENT a, CONTENT b) => a -> b -> Content a +++ b = Content (contentlist (toContent a) ++ contentlist (toContent b)) class ADDATTRS a where (!) :: a -> [Attr] -> a instance (ADDATTRS b) => ADDATTRS (a -> b) where fn ! attrs = \ arg -> fn arg ! attrs instance ADDATTRS Content where (Content tds) ! attrs = Content (map add_attrs tds) where add_attrs (Tag n s l x) = Tag n s (l++attrs) x add_attrs (ITag n s l) = ITag n s (l++attrs) add_attrs x = x data HTML = HTML String data DTD = Strict | Transitional | Frameset deriving Show xhtml1Doc dtd encoding x = "\n" ++ "\n" ++ show (toContent x) where dtdStr = show dtd dtdstr = map toLower dtdStr thehtml x = tag "html" ["xmlns"-="http://www.w3.org/1999/xhtml"] x thehead x = tag "head" [] x thetitle x = tag "title" [] x thebase x = tag "base" [] x meta sc = itag "meta" [Attr "content" sc] link = itag "link" [] style st x = tag "style" [Attr "type" st] x script st x = tag "script" [Attr "type" st] x noscript x = tag "noscript" [] x thebody x = tag "body" [] x divdiv x = tag "div" [] x p x = tag "p" [] x h1 x = tag "h1" [] x h2 x = tag "h2" [] x h3 x = tag "h3" [] x h4 x = tag "h4" [] x h5 x = tag "h5" [] x h6 x = tag "h6" [] x ul x = tag "ul" [] x ol x = tag "ol" [] x li x = tag "li" [] x dl x = tag "dl" [] x dt x = tag "dt" [] x dd x = tag "dd" [] x address x = tag "address" [] x hr = itag "hr" [] pre x = tag "pre" [] x blockquote x = tag "blockquote" [] x ins x = tag "ins" [] x del x = tag "del" [] x a x = tag "a" [] x spanspan x = tag "span" [] x bdo sd x = tag "bdo" [Attr "dir" sd] x br = itag "br" [] em x = tag "em" [] x strong x = tag "strong" [] x dfn x = tag "dfn" [] x code x = tag "code" [] x samp x = tag "samp" [] x kbd x = tag "kbd" [] x var x = tag "var" [] x cite x = tag "cite" [] x abbr x = tag "abbr" [] x acronym x = tag "acronym" [] x sub x = tag "sub" [] x sup x = tag "sup" [] x q x = tag "acronym" [] x tt x = tag "tt" [] x i x = tag "i" [] x b x = tag "b" [] x big x = tag "big" [] x small x = tag "small" [] x object x = tag "object" [] x param x = tag "param" [] x img ss sa = itag "img" [Attr "src" ss, Attr "alt" sa] mapmap si x = tag "map" [Attr "id" si] x area sa = itag "area" [Attr "alt" sa] form sa x = tag "form" [Attr "action" sa] x label x = tag "label" [] x input = itag "input" [] select x = tag "select" [] x optgroup sl x = tag "optgroup" [Attr "label" sl] x option x = tag "option" [] x textarea r c x = tag "textarea" [Attr "rows" $ show r, Attr "cols" $ show c] x fieldset x = tag "fieldset" [] x legend x = tag "legend" [] x button x = tag "button" [] x table x = tag "table" [] x caption x = tag "caption" [] x colgroup x = tag "colgroup" [] x col x = tag "col" [] x thead x = tag "thead" [] x tfoot x = tag "tfoot" [] x tbody x = tag "tbody" [] x tr x = tag "tr" [] x th x = tag "th" [] x td x = tag "td" [] x