Implementing elm-like to HTML

Html.hs

module Html (Html, div', text, render) where

type Reducer a b = (b -> a -> b)

type Tag =
  String

type Attribute msg =
  (String, String)

type Attributes msg =
  [Attribute msg]

type HtmlContent msg =
  [Html msg]

type HtmlTag msg = (Attributes msg -> HtmlContent msg -> Html msg)

data Html msg
  = Html Tag (Attributes msg) (HtmlContent msg)
  | Text String

htmlTag :: Tag -> HtmlTag msg
htmlTag tagName attr content =
  Html tagName attr content

a :: HtmlTag msg
a = htmlTag "a"

abbr :: HtmlTag msg
abbr = htmlTag "abbr"

acronym :: HtmlTag msg
acronym = htmlTag "acronym"

address :: HtmlTag msg
address = htmlTag "address"

applet :: HtmlTag msg
applet = htmlTag "applet"

area :: HtmlTag msg
area = htmlTag "area"

b :: HtmlTag msg
b = htmlTag "b"

base :: HtmlTag msg
base = htmlTag "base"

basefont :: HtmlTag msg
basefont = htmlTag "basefont"

bdo :: HtmlTag msg
bdo = htmlTag "bdo"

big :: HtmlTag msg
big = htmlTag "big"

blockquote :: HtmlTag msg
blockquote = htmlTag "blockquote"

body :: HtmlTag msg
body = htmlTag "body"

br :: HtmlTag msg
br = htmlTag "br"

button :: HtmlTag msg
button = htmlTag "button"

caption :: HtmlTag msg
caption = htmlTag "caption"

center :: HtmlTag msg
center = htmlTag "center"

cite :: HtmlTag msg
cite = htmlTag "cite"

code :: HtmlTag msg
code = htmlTag "code"

col :: HtmlTag msg
col = htmlTag "col"

colgroup :: HtmlTag msg
colgroup = htmlTag "colgroup"

dd :: HtmlTag msg
dd = htmlTag "dd"

del :: HtmlTag msg
del = htmlTag "del"

dfn :: HtmlTag msg
dfn = htmlTag "dfn"

dir :: HtmlTag msg
dir = htmlTag "dir"

div' :: HtmlTag msg
div' = htmlTag "div"

dl :: HtmlTag msg
dl = htmlTag "dl"

dt :: HtmlTag msg
dt = htmlTag "dt"

em :: HtmlTag msg
em = htmlTag "em"

fieldset :: HtmlTag msg
fieldset = htmlTag "fieldset"

font :: HtmlTag msg
font = htmlTag "font"

form :: HtmlTag msg
form = htmlTag "form"

frame :: HtmlTag msg
frame = htmlTag "frame"

frameset :: HtmlTag msg
frameset = htmlTag "frameset"

head :: HtmlTag msg
head = htmlTag "head"

hr :: HtmlTag msg
hr = htmlTag "hr"

html :: HtmlTag msg
html = htmlTag "html"

i :: HtmlTag msg
i = htmlTag "i"

iframe :: HtmlTag msg
iframe = htmlTag "iframe"

img :: HtmlTag msg
img = htmlTag "img"

input :: HtmlTag msg
input = htmlTag "input"

ins :: HtmlTag msg
ins = htmlTag "ins"

kbd :: HtmlTag msg
kbd = htmlTag "kbd"

label :: HtmlTag msg
label = htmlTag "label"

legend :: HtmlTag msg
legend = htmlTag "legend"

li :: HtmlTag msg
li = htmlTag "li"

link :: HtmlTag msg
link = htmlTag "link"

map :: HtmlTag msg
map = htmlTag "map"

menu :: HtmlTag msg
menu = htmlTag "menu"

meta :: HtmlTag msg
meta = htmlTag "meta"

noframes :: HtmlTag msg
noframes = htmlTag "noframes"

noscript :: HtmlTag msg
noscript = htmlTag "noscript"

object :: HtmlTag msg
object = htmlTag "object"

ol :: HtmlTag msg
ol = htmlTag "ol"

optgroup :: HtmlTag msg
optgroup = htmlTag "optgroup"

option :: HtmlTag msg
option = htmlTag "option"

p :: HtmlTag msg
p = htmlTag "p"

param :: HtmlTag msg
param = htmlTag "param"

pre :: HtmlTag msg
pre = htmlTag "pre"

q :: HtmlTag msg
q = htmlTag "q"

s :: HtmlTag msg
s = htmlTag "s"

samp :: HtmlTag msg
samp = htmlTag "samp"

script :: HtmlTag msg
script = htmlTag "script"

select :: HtmlTag msg
select = htmlTag "select"

small :: HtmlTag msg
small = htmlTag "small"

span :: HtmlTag msg
span = htmlTag "span"

strike :: HtmlTag msg
strike = htmlTag "strike"

strong :: HtmlTag msg
strong = htmlTag "strong"

style :: HtmlTag msg
style = htmlTag "style"

sub :: HtmlTag msg
sub = htmlTag "sub"

sup :: HtmlTag msg
sup = htmlTag "sup"

table :: HtmlTag msg
table = htmlTag "table"

tbody :: HtmlTag msg
tbody = htmlTag "tbody"

td :: HtmlTag msg
td = htmlTag "td"

textarea :: HtmlTag msg
textarea = htmlTag "textarea"

tfoot :: HtmlTag msg
tfoot = htmlTag "tfoot"

th :: HtmlTag msg
th = htmlTag "th"

thead :: HtmlTag msg
thead = htmlTag "thead"

title :: HtmlTag msg
title = htmlTag "title"

tr :: HtmlTag msg
tr = htmlTag "tr"

tt :: HtmlTag msg
tt = htmlTag "tt"

u :: HtmlTag msg
u = htmlTag "u"

ul :: HtmlTag msg
ul = htmlTag "ul"

var :: HtmlTag msg
var = htmlTag "var"

text :: String -> Html msg
text = Text

renderAttr :: Attribute msg -> String
renderAttr (prop, "") = prop
renderAttr (prop, value) =
  prop <> "=" <> "\"" <> value <> "\""

attributesReducer :: Reducer (Attribute msg) String
attributesReducer "" a = " " <> (renderAttr a)
attributesReducer acc a = acc <> " " <> (renderAttr a)

contentReducer :: Reducer String String
contentReducer acc c = acc <> c <> "\n\t"

renderContent :: HtmlContent msg -> String
renderContent = reverse . drop 2 . reverse . foldl contentReducer "\t" . fmap render

renderAttributes :: Attributes msg -> String
renderAttributes attrs =
  foldl attributesReducer "" attrs

render :: Html msg -> String
render (Text string) = string
render (Html tag attrs htmlContent) =
  "<" <> tag <> attributes <> ">" <> "\n" <> content <> "\n" <> "</" <> tag <> ">"
  where
    attributes = renderAttributes attrs
    content = renderContent htmlContent