1 files changed, 79 insertions, 0 deletions

@@ -0,0 +1,79 @@
+;;; schmaltz --- render scheme forms in text
+;; every effort has been made to make this portable code, or at least to hide
+;; the unportability behind configuration.
+
+(define render
+  (case-lambda
+    (()
+     (render (current-input-port) (render-environment)))
+    ((port)
+     (render port (render-environment)))
+    ((port env)
+     (let loop ((ch (read-char port))
+                (acc '()))
+       (cond
+        ((not ch)                       ; after an expansion
+         (loop (read-char port) acc))
+        ((eof-object? ch)               ; end of file
+         (list->string (reverse acc)))
+        ((eq? ch #\#)                  ; expansion
+         (let* ((next (peek-char port))
+                (proc (assq-ref next (render-specials))))
+           (cond
+            ((eq? next #\\)             ; escape character -- #\,( => #,(
+             (read-char port)           ; skip the \
+             (loop (read-char port)     ; continue
+                   (cons ch acc)))
+            ((not proc)                 ; this character isn't special
+             (loop (read-char port)     ; continue
+                   (cons ch acc)))
+            (else                       ; look up the reader and run it
+             (read-char port)           ; skip the character
+             (loop #f (append (let* ((ins (displayed (eval (proc port) env)))
+                                     (out (assoc ins (render-unprintables))))
+                                (if out
+                                    ((cdr out) next)
+                                    (reverse (string->list ins))))
+                              acc))))))
+        (else (loop (read-char port)    ; normal character
+                    (cons ch acc))))))))
+
+(define render-string
+  (case-lambda
+    ((s) (render-string s (interaction-environment)))
+    ((s env)
+     (call-with-port (open-input-string s)
+       (lambda (port)
+         (render env port))))))
+
+;;; Configuration
+
+(define render-environment
+  (make-parameter
+   (interaction-environment)))
+
+(define render-specials
+  ;; Alist of (CHAR . PROCEDURE) mapping input characters to special reader
+  ;; meanings.  Each PROCEDURE should take one parameter, a port.
+  (make-parameter
+   (list (cons #\, (lambda (port) (eval (read port) ; standard scheme read
+                                   (interaction-environment))))
+         #;(cons #\@ (lambda (port)     ; wrap the next form in `sxml->html'
+         `(sxml->html ,(list 'quasiquote (read port))))))))
+
+(define render-unprintables
+  (make-parameter
+   (list #;(cons "#<unspecified>" (lambda _ '()))
+    #;(cons "#!eof" (lambda (ch) (list ch #\#))))))
+
+;;;: Utilities
+
+(define (displayed x)
+  (call-with-port (open-output-string)
+    (lambda (port)
+      (display x port)
+      (get-output-string port))))
+
+(define (assq-ref key lis)
+  (let ((val (assq key lis)))
+    (if val (cdr val) #f)))