GADTs to generate custom XML

prog.hs

{-# LANGUAGE GADTs #-}

import Text.XML.Light

mkElt :: String -> (Attributes, Body) -> Element
mkElt name (attribs, body) = Element {
  elName = unqual name,
  elAttribs = map (\(k, v) -> Attr (unqual k) v) attribs,
  elContent = [Text (CData CDataRaw body Nothing)],
  elLine = Nothing
  }

addChild :: Element -> Element -> (Attributes, Body) -> Element
addChild parent@(Element _ _ obody _) child@(Element _ attr cbody _) (attribs, body) = parent {
  elContent = obody ++ [Elem myChild]
  }
  where
    myChild = child {
	elAttribs = attr ++ (map (\(k, v) -> Attr (unqual k) v) attribs),
	elContent = cbody ++ [Text (CData CDataRaw body Nothing)]
      }

emptyElem :: Element
emptyElem = mkElt "" ([], "")

data Response
data Speak
data Play
data SendAnswer

data MyXMLElement a b where
  MkResponse :: b -> MyXMLElement Response b
  MkSpeak :: b -> MyXMLElement Speak b
  MkPlay :: b -> MyXMLElement Play b
  MkSendAnswer :: b -> MyXMLElement SendAnswer b
  AddPlayToResponse :: MyXMLElement Play b -> MyXMLElement Response b -> MyXMLElement Response b
  AddPlayToSendAnswer :: MyXMLElement Play b -> MyXMLElement SendAnswer b -> MyXMLElement Response b
  AddSpeakToResponse :: MyXMLElement Speak b -> MyXMLElement Response b -> MyXMLElement Response b
  AddSpeakToSendAnswer :: MyXMLElement Speak b -> MyXMLElement SendAnswer b -> MyXMLElement SendAnswer b
  AddSendAnswerToResponse :: MyXMLElement SendAnswer b -> MyXMLElement Response b -> MyXMLElement SendAnswer b

type Attributes = [(String, String)]
type Body = String

eval :: MyXMLElement a Element -> (Attributes, Body) -> Element
eval (MkResponse b) (attribs, body) = mkElt "Response" (attribs, body)
eval (MkSpeak b) (attribs, body) = mkElt "Speak" (attribs, body)
eval (MkSendAnswer b) (attribs, body) = mkElt "SendAnswer" (attribs, body)
eval (MkPlay b) (attribs, body) = mkElt "Play" (attribs, body)
eval (AddPlayToResponse playElt respElt) (attribs, body) = 
  addChild (eval respElt ([], "")) (eval playElt ([], "")) (attribs, body)
eval (AddPlayToSendAnswer playElt sendElt) (attribs, body) = 
  addChild (eval sendElt ([], "")) (eval playElt ([], "")) (attribs, body)
eval (AddSpeakToResponse speakElt respElt) (attribs, body) = 
  addChild (eval respElt ([], "")) (eval speakElt ([], "")) (attribs, body)
eval (AddSpeakToSendAnswer speakElt sendAnsElt) (attribs, body) = 
  addChild (eval sendAnsElt ([], "")) (eval speakElt ([], "")) (attribs, body)
eval (AddSendAnswerToResponse sendElt respElt) (attribs, body) = 
  addChild (eval respElt ([], "")) (eval sendElt ([], "")) (attribs, body)

main :: IO ()
main = do
  let speak = MkSpeak emptyElem
      resp = AddSpeakToResponse speak (MkResponse emptyElem)
  putStrLn.ppElement $ eval resp ([("loop", "2")], "http://example.com/a.mp3")