htmlを吐き出す2 - Rodhos Soft

html吐き出すコード、DivTag DIVとか書くのはおかしい。もっとまとまるはず。。
import Data.List
main = putStr (tag_doctype ++ html)

tag_doctype = "<!DOCTYPE html>"

html = string (HTML [header,body])
header = HeadTag (HEAD (String "OK!"))
body =  BodyTag (BODY htmlbody)

htmlbody = DivTag (DIV (PTag (P (String "Hello"))))

class TransString a where
  string::a -> String
  stringjoin::[a] -> String
  stringjoin list = intercalate "" (map string list)



data Anchor = A { aURL::String, aLabel::String}
instance TransString Anchor where
  string (A { aURL=u, aLabel=l}) = (tagatt "a" (attr "href" (qua u)) l)

-- 色々なタグをタグでまとめた。
data TAG =HTMLTag HTMLTAG
          |HeadTag HEADERTAG
          |BodyTag BODYTAG
          |TitleTag TITLETAG
          |DivTag DIVTAG
          |PTag PTAG
          |String String

instance TransString TAG where
  string (HeadTag tag) = string tag
  string (BodyTag tag) = string tag
  string (TitleTag tag) = string tag
  string (DivTag tag) = string tag
  string (PTag tag) = string tag
  string (String txt) = txt


data HTMLTAG = HTML { htmlText::[TAG]}
instance TransString HTMLTAG where
  string (HTML { htmlText=tags}) =  tag "html" (stringjoin tags)

data HEADERTAG = HEAD { headTag::TAG}
instance TransString HEADERTAG where
  string (HEAD { headTag=tag_}) = tag "head" (string tag_)

data BODYTAG = BODY { bodyTag::TAG}
instance TransString BODYTAG where
  string (BODY { bodyTag=tag_}) = tag "body" (string tag_)

data TITLETAG = TITLE { titleTag::TAG}
instance TransString TITLETAG where
  string (TITLE { titleTag=tag_}) = tag "title" (string tag_)

data DIVTAG = DIV { divTag::TAG}
instance TransString DIVTAG where
  string (DIV { divTag=tag_}) = tag "div" (string tag_)

data PTAG = P { pTag::TAG}
instance TransString PTAG where
  string (P {pTag=tag_}) = tag "p" (string tag_)

tag::String -> String -> String
tag name txt = "<"++name++">" ++ txt ++ "</"++name++">"

attr::String -> String -> String
attr name txt = name ++ "=" ++ txt

tagatt::String -> String -> String->String
tagatt name att txt = "<" ++ name ++ " " ++ att ++ ">" ++ txt ++ "</"++name++">"

qua::String->String
qua txt = "'" ++ txt ++ "'"

trycode::(TransString a) => a -> String
trycode x = string x