{--
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' ++ ""++s++">\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 ++
""++s++">"
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