1 files changed, 101 insertions, 0 deletions
diff --git a/weeb/sxml.scm b/weeb/sxml.scm
new file mode 100644
index 0000000..b51abbc
--- /dev/null
+++ b/weeb/sxml.scm
@@ -0,0 +1,101 @@
+;;; Weeb --- Web microframework for GNU Guile
+;;; Copyright © 2026 Jakob Kreuze <zerodaysfordays@sdf.org>
+;;;
+;;; This file is part of Weeb.
+;;;
+;;; Weeb is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Affero General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Weeb is distributed in the hope that it will be useful, but WITHOUT
+;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+;;; Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (weeb sxml)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 string-fun)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (sxml->html
+            sxml->html-document))
+
+(define (self-closing? tag-name)
+  (memq tag-name '(img br hr input)))
+
+(define (emit-raw? tag-name)
+  (memq tag-name '(style script)))
+
+(define (sxml-tag? elt)
+  (match elt
+    ((_tag-name ('@ _attr ...) _content ...) #t)
+    ((_tag-name _content ...) #t)
+    (_ #f)))
+
+(define (extract-tag-name tag)
+  (first tag))
+
+(define (extract-attributes tag)
+  (match tag
+    ((_tag-name ('@ attrs ...) _content ...) attrs)
+    (_ '())))
+
+(define (extract-children tag)
+  (match tag
+    ((_tag-name ('@ _attrs ...) content ...) content)
+    ((_tag-name content ...) content)
+    (_ '())))
+
+;; TODO: We should probably encode other entities as well, but there are
+;; hundreds, so we need a more efficient way of substituting first.
+(define (html-encode str)
+  (define %entities
+    '((#\& . "&amp;")
+      (#\< . "&lt;")
+      (#\> . "&gt;")
+      (#\" . "&quot;")
+      (#\' . "&#39;")))
+  (define (iter s replace)
+    (match replace
+      (((char . entity) rest ...)
+       (iter (string-replace-substring s (string char) entity) rest))
+      (() s)))
+  (iter str %entities))
+
+(define (emit-sxml-tree tree)
+  (match tree
+    ((? sxml-tag?)
+     (let ((tag-name (extract-tag-name tree)))
+       (display "<")
+       (display tag-name)
+       (for-each (match-lambda
+                   ((key value)
+                    (display " ")
+                    (display key)
+                    (display "=\"")
+                    (display value)
+                    (display "\"")))
+                 (extract-attributes tree))
+       (display ">")
+       (unless (self-closing? tag-name)
+         (if (emit-raw? tag-name)
+             (display (second tree))
+             (for-each emit-sxml-tree (extract-children tree)))
+         (display "</")
+         (display tag-name)
+         (display ">"))))
+    ((? string?) (begin (display (html-encode tree))))
+    ((? number?) (begin (display tree)))))
+
+(define (emit-sxml-document document)
+  (display "<!DOCTYPE html>")
+  (emit-sxml-tree document))
+
+(define (sxml->html tree)
+  (with-output-to-string (cut emit-sxml-tree tree)))
+(define (sxml->html-document tree)
+  (with-output-to-string (cut emit-sxml-document tree)))