Dollar-sign style string interpolation in R6RS

string-interpolation.scm

;;;
;;; Usage:
;;;
;;; ($"some normal text: $with $identifiers substituted in by the $dollar-sign")
;;; ($"You can also $(embed full expressions)")
;;; ($"Because scheme has $very-inclusive-identifier.rules, $(this) is the same as $this")
;;; ($"However, if you have $(multiple items) inside the parentheticals, $multiple is called with $item as the argument")
;;; ($"A zero argument $((function)) will be called like that")
;;; ($"Yes, this means $(funcion call) and $((function call)) are the same")
;;;

(library (string-interpolation)
  (export $ ->string)
  (import (rnrs))

  (define (->string x)
    (cond
      [(string? x) x]
      [(symbol? x) (symbol->string x)]
      [(number? x) (number->string x)]
      [else (call-with-string-output-port
              (lambda (p)
                (display x p)))]))

  (define-syntax $
    (lambda (x)
      (syntax-case x ()
        [(k str) (string? (syntax->datum #'str))
         (let-values ([(in) (open-string-input-port (syntax->datum #'str))]
                      [(out get) (open-string-output-port)])

           (define (loop char)
             (cond
               [(eof-object? char) (list (get))]
               [(not (char=? char #\$))
                (put-char out char)
                (loop (get-char in))]
               [(char=? (peek-char in) #\$)
                (put-char out (get-char in))
                (loop (get-char in))]
               [else (let* ([s (get)]
                            [expr (read in)]
                            [expr^ (cond
                                     [(not (pair? expr)) expr]
                                     [(null? (cdr expr)) (car expr)]
                                     [else expr])])
                       (cons* s #`(->string #,(datum->syntax #'k expr^))
                         (loop (get-char in))))]))

           #`(string-append #,@(loop (get-char in))))])))
)