;;; 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))))))

(define (render->string . args)
  (call-with-port (open-output-string)
    (lambda (out)
      (apply render args)
      (get-output-string out))))

(define (render-string->string str . args)
  (call-with-port (open-output-string)
    (lambda (out)
      (apply render-string args)
      (get-output-string out))))

;;; 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)))

(define (unprintable/skip . _)
  '())

(define (unprintable/backtrack ch)
  (list ch #\#))
         (display (list->string (reverse acc))))