6 files changed, 193 insertions, 0 deletions

@@ -0,0 +1,4 @@
+;;; Directory Local Variables            -*- no-byte-compile: t -*-
+;;; For more information see (info "(emacs) Directory Variables")
+
+((scheme-mode . ((geiser-scheme-implementation . chicken))))
@@ -0,0 +1,8 @@
+schmaltz
+*.link
+*.so
+*.o
+*.build.sh
+*.import.scm
+*.install.sh
+*.link
\ No newline at end of file
@@ -0,0 +1,24 @@
+;;; (schmaltz) --- render CHICKEN in texts
+
+((synopsis "Render scheme form in texts.")
+ (author "Case Duckworth")
+ (version "0.1.0")
+ (license "God Willing License")
+
+ (dependencies r7rs utf8 srfi-1)
+
+ (component-options
+  (csc-options -X r7rs -R r7rs
+               -X utf8 -R utf8
+               -no-warnings))
+
+ (components
+  (program schmaltz
+           (source schmaltz.scm)
+           (component-dependencies schmaltz-lib))
+
+  (extension schmaltz-lib
+             (source schmaltz.sld)
+             (modules schmaltz)
+             (install-name schmaltz)
+             (source-dependencies schmaltz.sls))))
@@ -0,0 +1,58 @@
+;;; schmaltz --- the command-line program
+;; This is not written portably.
+
+(cond-expand
+  (chicken (import r7rs utf8))
+  (else))
+
+(import (schmaltz)
+        (scheme file)
+        (scheme eval)
+        (scheme repl)
+        (srfi 1))
+
+(cond-expand
+  (chicken
+   (render-specials
+    (cons (cons #\@ (lambda (port)           ; wrap the next form in `sxml->html'
+                      ;; wow this is ugly ... how can i make this better?
+                      (eval '(import (html-parser)) (interaction-environment))
+                      `(sxml->html ,(list 'quasiquote (read port)))))
+          (render-specials)))
+   (render-unprintables
+    (list (cons "#<unspecified>" (lambda _ '()))
+          (cons "#!eof" (lambda (ch) (list ch #\#))))))
+  (else))
+
+(define (main args)
+  (define (display-render)
+    (display (render))
+    (newline))
+  (define (rout file)
+    (with-input-from-file file display-render))
+  (cond
+   ((and (null? args)                   ; input from stdin
+         (char-ready?))
+    (display-render))
+   ((member "-" args)
+    (let-values (((fs1 fs2)
+                  (break (lambda (x) (equal? x "-"))
+                         args)))
+      (for-each rout fs1)
+      (display-render)
+      (for-each rout (cdr fs2))))
+   ((< 0 (length args))
+    (for-each rout args))
+   (else
+    (display "Usage: schmaltz FILE...\n" (current-error-port))
+    (exit 1))))
+
+(cond-expand
+  ((and chicken
+        (or chicken-script compiling))
+   (import (chicken process-context))
+   (main (command-line-arguments)))
+  (chicken)
+  (else
+   (import (scheme process-context))
+   (main (cdr (command-line)))))
@@ -0,0 +1,20 @@
+(define-library (schmaltz)
+  (export render
+          render-string
+          ;; Configuration
+          render-specials
+          render-unprintables
+          render-environment
+          ;; Re-exports
+          environment
+          )
+
+  (import (scheme base)
+          (scheme case-lambda)
+          (scheme eval)
+          (scheme read)
+          (scheme repl)
+          (scheme write)
+          (srfi 1))
+
+  (include "schmaltz.sls"))
@@ -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)))