From d4830cdd422258a7c91a5ed07af50f8c208a29ee Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Tue, 15 Aug 2023 23:33:17 -0500
Subject: A new start (again)

---
 lib/schmaltz.sls | 103 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 103 insertions(+)
 create mode 100644 lib/schmaltz.sls

(limited to 'lib/schmaltz.sls')

diff --git a/lib/schmaltz.sls b/lib/schmaltz.sls
new file mode 100644
index 0000000..623191f
--- /dev/null
+++ b/lib/schmaltz.sls
@@ -0,0 +1,103 @@
+;;; (boudin schmaltz) --- transform almost-html plus scheme into html
+
+;;; Embedded scheme code
+
+(define (->string x)
+  (call-with-port (open-output-string)
+    (lambda (port)
+      (display x port)
+      (get-output-string port))))
+
+(define render-string
+  (case-lambda
+    ((s) (render-string s (interaction-environment)))
+    ((s env)
+     (call-with-port (open-input-string s)
+       (lambda (port)
+         (render port env))))))
+
+(define (render port env)
+  ;; A few rough edges:
+  ;; #, x will try to render x
+  (define (burn-char)
+    ;; Throw a character away.  I've defined this for clarity below.
+    (read-char port))
+
+  (let loop ((ch (read-char port))
+             (acc '()))
+    (define (proceed) (loop (read-char port) (cons ch acc)))
+    (cond
+     ((not ch)
+      (loop (read-char port) acc))
+     ((eof-object? ch)
+      (list->string (reverse acc)))
+     ((eq? ch #\#)                      ; special processing to come
+      (case (peek-char port)
+        ((#\\)                          ; inhibit processing of the next char
+         (burn-char)
+         (loop (read-char port) (cons ch acc)))
+        ((#\,)                          ; scheme eval expansion
+         (burn-char)
+         (loop #f
+               (append (let ((s (->string
+                                 (eval (read port)
+                                       env))))
+                         (cond
+                          ((equal? s "#<unspecified>") ; XXX NOT PORTABLE
+                           '())
+                          ((equal? s "#!eof") ; XXX NOT PORTABLE
+                           '(#\, #\#))
+                          (else (reverse (string->list s)))))
+                       acc)))
+        ((#\@)                          ; embedded sxml
+         (burn-char)
+         (loop #f
+               (append (let ((h (eval `(sxml->html ,(list 'quasiquote
+                                                          (read port)))
+                                      env)))
+                         (cond
+                          ((equal? h "#!eof") ; XXX NOT PORTABLE
+                           '(#\@ #\#))
+                          (else (reverse (string->list h)))))
+                       acc)))
+        (else (proceed))))
+     (else (proceed)))))
+
+;;; Wrap paragraphs
+
+(define (split-paragraphs str)
+  (let loop ((lines (string-split str "\n"))
+             (par '())
+             (acc '()))
+    (cond
+     ((and (null? lines)                ; base case: no more lines
+           (null? par))                 ; ... or pending paragraph
+      (reverse acc))
+     ((null? lines)                     ; add the final paragraph
+      (loop '() '() (cons (apply string-append (reverse par)) acc)))
+     ((equal? (car lines) "")           ; paragraph break
+      (loop (cdr lines)
+            '()
+            (cons (apply string-append (reverse par)) acc)))
+     (else                              ; line break
+      (loop (cdr lines)
+            (cons (string-append (car lines) "\n") par)
+            acc)))))
+
+(define (wrap-paragraphs str)
+  (let loop ((pars (split-paragraphs str))
+             (acc '()))
+    (cond
+     ((null? pars)
+      (apply string-append (reverse acc)))
+     ((zero? (string-length (car pars)))
+      (loop (cdr pars)
+            acc))
+     ((eq? #\< (string-ref (string-trim (car pars)) 0))
+      (loop (cdr pars)
+            (cons (car pars)
+                  acc)))
+     (else
+      (loop (cdr pars)
+            (cons (string-append "<p>" (car pars) "</p>\n")
+                  acc))))))
-- 
cgit 1.4.1-21-gabe81