From ed1ccc444828d9ef377d71e6a7bab4400a4d30fb Mon Sep 17 00:00:00 2001
From: Benjamin Pollack <benjamin@bitquabit.com>
Date: Fri, 11 Mar 2016 11:01:22 -0500
Subject: [PATCH] chloe: ensure self-closing tags are self-closing

This gets us much closer to HTML5 compatibility, while not breaking the
existing XHTML functionality. (Indeed, the entire reason this is necessary is
that XHTML, being an XML derivative, treats `<foo></foo>` and `<foo />`
equivalently, whereas HTML5 does not.)
---
 .../templates/chloe/compiler/compiler.factor  | 40 +++++++++++++++----
 1 file changed, 33 insertions(+), 7 deletions(-)

diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor
index 1c7c73c90f..1d83a568da 100644
--- a/basis/html/templates/chloe/compiler/compiler.factor
+++ b/basis/html/templates/chloe/compiler/compiler.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs namespaces make kernel sequences accessors
 combinators strings splitting io io.streams.string present
-xml.writer xml.data xml.entities html.forms
+sets ascii xml.writer xml.data xml.entities html.forms
 html.templates html.templates.chloe.syntax ;
 IN: html.templates.chloe.compiler
 
@@ -60,6 +60,11 @@ DEFER: compile-element
         "\"" [write]
     ] assoc-each ;
 
+: compile-self-closing-tag ( tag -- )
+    "<" [write]
+    [ name>string [write] ] [ attrs>> compile-attrs ] bi
+    " />" [write] ;
+
 : compile-start-tag ( tag -- )
     "<" [write]
     [ name>string [write] ] [ attrs>> compile-attrs ] bi
@@ -74,17 +79,38 @@ SYMBOL: string-context?
 
 ERROR: tag-not-allowed-here ;
 
+CONSTANT: self-closing-tags {
+        "area"
+        "base"
+        "br"
+        "embed"
+        "hr"
+        "iframe"
+        "img"
+        "input"
+        "link"
+        "meta"
+        "param"
+        "source"
+        "track"
+    }
+
 : check-tag ( -- )
     string-context? get [ tag-not-allowed-here ] when ;
 
-: compile-tag ( tag -- )
-    check-tag
-    {
-        [ main>> tag-stack get push ]
+: (compile-tag) ( tag -- )
+    dup name>string >lower self-closing-tags in?
+    [ compile-self-closing-tag ]
+    [
         [ compile-start-tag ]
         [ compile-children ]
-        [ compile-end-tag ]
-    } cleave
+        [ compile-end-tag ] tri
+    ] if ;
+
+: compile-tag ( tag -- )
+    check-tag
+    [ main>> tag-stack get push ]
+    [ (compile-tag) ] bi
     tag-stack get pop* ;
 
 ERROR: unknown-chloe-tag tag ;