Template compiler in Haskell

arrival.hs

--- We just read whatever comes from standard input and spit out its conversion result
main = interact louise

--- Our runner will just pipe the three components together:
louise :: String -> String
louise html = let result = parseHTML html >>= html2js >>= writeJS in
    case result of
        Right ok -> ok
        Left nok -> "Error: " ++ nok
        
--- From there, we can figure out the signature of each function
parseHTML :: String -> Either ParseError HtmlAst
html2js :: HtmlAst -> Either ValidationError Dom
writeJS :: Dom -> Either String String

--- Let's define our error cases
data ValidationError = MisnestedTag String

instance Error ValidationError where
    noMsg = "mismatched tags"
    strMsg s = "misnested tag " + s

--- We'll need Parsec, the parser combinator library
import Text.ParserCombinators.Parsec

--- Let's start with our HTML parser
htmlFrag :: GenParser Char st AST
htmlFrag = do
    result <- many node
    eof
    return ((Node Fragment 0 -1 "#root" "" -1 -1):result)

node =   try elementNode
     <|> try textNode
     <|> commentNode
     <?> "unknown input type"

elementNode = match res of
    Just nodes -> nodes
    _          ->
    in do
        (el1,attrs) <- startTag
        children    <- many node
        el2         <- endTag
        if (name el1) == (name el2)
            then return Just ((Node Element (id el1) (parent el1) (name el1) "" (pre (parent 1) + 1) (post (last children) + 1)) : attrs : children)
            else return None

startTag = do
    char '<'
    tag   <- tagName
    attrs <- attributes
    try (string "/>")
        <|> string ">"
    return ((Node Element _ _ tag _ _ _), attrs)

endTag = do
    char '<'
    char '/'
    tag

nonVoidElement = do
    st <- startTag

voidTagName =   try (string "area")
            <|> try (string "base")
            <|> try (string "br")
            <|> try (string "col")
            <|> try (string "command")
            <|> try (string "embed")
            <|> try (string "hr")
            <|> try (string "img")
            <|> try (string "input")
            <|> try (string "keygen")
            <|> try (string "link")
            <|> try (string "meta")
            <|> try (string "param")
            <|> try (string "source")
            <|> try (string "track")
            <|> try (string "wbr")

startTag = do
    char '<'
    tagName <- nonVoidTagName
    attrs <- attributes
    many spaceChar
    char '>'
    return (Node Element _ _ tagName _ _ _ : attrs)

nonVoidTagName =   try (string "abbr")
               <|> try (string "address")
               <|> try (string "article")
               <|> try (string "aside")
               <|> try (string "audio")
               <|> try (string "a")
               <|> try (string "bdi")
               <|> try (string "bdo")
               <|> try (string "blockquote")
               <|> try (string "button")
               <|> try (string "b")
               <|> try (string "canvas")
               <|> try (string "caption")
               <|> try (string "cite")
               <|> try (string "code")
               <|> try (string "colgroup")
               <|> try (string "datalist")
               <|> try (string "dd")
               <|> try (string "del")
               <|> try (string "details")
               <|> try (string "dfn")
               <|> try (string "div")
               <|> try (string "dl")
               <|> try (string "dt")
               <|> try (string "em")
               <|> try (string "fieldset")
               <|> try (string "figcaption")
               <|> try (string "figure")
               <|> try (string "footer")
               <|> try (string "form")
               <|> try (string "h1")
               <|> try (string "h2")
               <|> try (string "h3")
               <|> try (string "h4")
               <|> try (string "h5")
               <|> try (string "h6")
               <|> try (string "header")
               <|> try (string "hgroup")
               <|> try (string "iframe")
               <|> try (string "i")
               <|> try (string "ins")
               <|> try (string "kbd")
               <|> try (string "label")
               <|> try (string "legend")
               <|> try (string "li")
               <|> try (string "map")
               <|> try (string "mark")
               <|> try (string "menu")
               <|> try (string "meter")
               <|> try (string "nav")
               <|> try (string "noscript")
               <|> try (string "object")
               <|> try (string "ol")
               <|> try (string "optgroup")
               <|> try (string "option")
               <|> try (string "output")
               <|> try (string "pre")
               <|> try (string "p")
               <|> try (string "progress")
               <|> try (string "q")
               <|> try (string "rp")
               <|> try (string "rt")
               <|> try (string "ruby")
               <|> try (string "samp")
               <|> try (string "script")
               <|> try (string "section")
               <|> try (string "select")
               <|> try (string "small")
               <|> try (string "span")
               <|> try (string "strong")
               <|> try (string "style")
               <|> try (string "sub")
               <|> try (string "summary")
               <|> try (string "sup")
               <|> try (string "s")
               <|> try (string "table")
               <|> try (string "tbody")
               <|> try (string "textarea")
               <|> try (string "tfoot")
               <|> try (string "thead")
               <|> try (string "time")
               <|> try (string "title")
               <|> try (string "tr")
               <|> try (string "th")
               <|> try (string "td")
               <|> try (string "ul")
               <|> try (string "var")
               <|> try (string "video")

endTag = do
    char '<'
    char '/'
    tagName <- many (noneOf "&<>")
    return [(Node Element _ _ tagName _ _ _)]

attributes = do
    many1 spaceChar
    sepBy attribute (many1 spaceChar)

attribute = do
    name <- many (noneOf "=")
    char '='
    char '"'
    value <- many (noneOf "=")
    char '"'
    return [(Node Attribute _ _ name value _ _)]

spaceChar = oneOf " \n\t"

type AST = [Node]

data Node = Node
    { nodeType :: NodeType
    , id       :: NodeId
    , parent   :: NodeId
    , name     :: String
    , value    :: String
    , pre      :: Int
    , post     :: Int
    }

data NodeType = Fragment | Text | Attribute | Element | Comment

type NodeId = Int

translate :: HTMLString -> JSString
translate html = case parseHTML html of
    Right ast -> "function () {"
        ++ write ast
        ++ "}"
    Left err -> error err

--- Let's just create type synomyms for convenience
type HTMLString = String
type JSString = String

--- Our parsing function will kick-off the parser combinator
parseHTML :: HTMLString -> Either ParseError AST
parseHTML input = parse htmlFrag "" input

---
writeJS :: AST -> JSString
writeJS [] = ""
writeJS (o:os) = case nodeType o of
    Fragment -> id o
        ++ " = document.createDocumentFragment();"
    Text -> parent o
        ++ ".appendChild(document.createTextNode(" ++ (value o) ++ "));"
        ++ write os
    Attribute -> parent o
        ++ ".setAttribute('" ++ (name o) ++ "', '" ++ (value o) ++ "');"
        ++ write os
    Comment -> parent o
        ++ ".appendChild(document.createComment(" ++ (value o) ++ "));"
        ++ write os
    Element -> id o
        ++ " = document.createElement('" ++ (name o) ++ "');"
        ++ write (range os start stop)
        ++ (parent o) ++ ".appendChild(" ++ (id o) ++ ")"
        ++ write (splice os start stop)