Heredoc Reader for Common Lisp

heredoc-reader.lisp

;; A fun reader macro which will read a HEREDOC in Bash style. That
;; is: take the section from the next line break until a line which
;; has only the delimiter on it.
;;
;; Example:
;;
;;   (list "a" <<JSON <<XML)
;;     {
;;       "a": "b"
;;     }
;;   JSON
;;     <a>
;;       <b />
;;     </a>
;;   XML
;;
;; Useful *and* magical.

(defvar *pending-heredocs* nil)

(defun read-until-delimiter-line (delimiter stream out)
  (loop
    (let ((index
            (loop
              :for i :upfrom 0
              :for expected :across delimiter
              :for actual = (peek-char nil stream)
              :unless (char= expected actual)
                :return i
              :do (read-char stream))))
      (case index
        ((nil) (return))
        ((0) (write-char (read-char stream) out))
        (t (write-string (subseq delimiter 0 index) out))))))

(defun read-pending-heredocs (stream &optional char)
  (declare (ignore char))
  (loop :while *pending-heredocs* :do
    (funcall (pop *pending-heredocs*) stream))
  (values))

(defun create-pending-heredoc (delimiter)
  (let ((result (make-array 0 :element-type 'character :fill-pointer t)))
    (flet ((reader (stream)
             (with-output-to-string (out result)
               (read-until-delimiter-line
                (format nil "~%~a~%" delimiter)
                stream
                out))))
      (if *pending-heredocs*
          (setf (cdr (last *pending-heredocs*)) (list #'reader))
          (push #'reader *pending-heredocs*)))
    result))

(defun read-heredoc (stream &optional subchar arg)
  (declare (ignore subchar arg))
  (create-pending-heredoc
   (with-output-to-string (out)
     (loop
       :for char = (peek-char nil stream)
       :for (reader continuing) = (multiple-value-list
                                   (get-macro-character char))
       :while (and (or (not reader) continuing)
                   (not (char= char #\space))
                   (not (char= char #\newline))
                   (not (char= char #\return)))
       :do
          (write-char (read-char stream) out)))))

(defun enable-heredocs! (&optional (readtable *readtable*))
  (set-dispatch-macro-character #\# #\< 'read-heredoc readtable)
  (set-macro-character #\newline 'read-pending-heredocs nil readtable))

(defun disable-heredocs! (&optional (readtable *readtable*))
  (set-dispatch-macro-character #\# #\< nil readtable)
  (set-macro-character #\newline (lambda (stream char)
                                   (declare (ignore stream char))
                                   (values))
                       nil
                       *readtable*))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (enable-heredocs!))

;; This should now work:
(print (list (list #<ABC #<DEF)))
  Something
ABC
  Something else
DEF