;;;; This file is part of Kira.
;;;;
;;;; Kira is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
;;;; as published by the Free Software Foundation; either version 2
;;;; of the License, or (at your option) any later version.
;;;;
;;;; Kira is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with Kira; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

(in-package :btl)

(defparameter *print-embedded-lisp* nil
  "Flag to print the actual content of embedded Lisp fragments.")

(defclass embedded-lisp ()
  (string :accessor embedded-lisp-string :initarg :string :initform nil))

(defclass btl ()
  (object :accessor btl-object :initarg :object :initform nil))

(defun btl (object)
  (make-instance 'btl :object object))

(defmethod print-object ((em embedded-lisp) stream)
  (if *print-embedded-lisp*
      (write-string (embedded-lisp-string em) stream)
      (call-next-method)))

(defmethod print-object ((b btl) stream)
  (let ((*print-embedded-lisp* t))
    (print-object (btl-object b) stream)))

(defun btl-interpolate-string (string)
  (collecting
    (with-input-from-string (stream string)
      (loop with buf = (make-string-output-stream)
	    for char = (read-char stream nil nil)
	    when (one-of-p char #\[ nil)
	    do (if (one-of-p (peek-char nil stream nil nil) #\[ nil)
		   (progn
		     (write-char #\[ buf)
		     (read-char stream nil nil))
		   (progn
		     (whereas ((output (maybe-get-output-stream-string buf)))
		       (collect output))
		     (loop for char = (read-char stream nil nil)
			   until (one-of-p char #\] nil)
			   do (write-char char buf)
			   finally (whereas ((output (maybe-get-output-stream-string buf)))
				     (collect (make-instance 'embedded-lisp :string output))))))
	    else do (write-char char buf)
	    while char))))

(defun btl-string-p (object)
  (and (stringp object) (find #\[ object)))

(defun btl-interpolate-attributes (attributes)
  (loop for (k v) on attributes by #'cddr
	collect k
	collect (if (btl-string-p v)
		    (let ((forms (btl-interpolate-string v)))
		      (if (rest forms)
			  `(*ml ,@forms)
			  (first forms)))
		    v)))

(defun btl-interpolate-element (element)
  (if (sometree #'btl-string-p element)
      (multiple-value-bind (name attributes content) (parse-element element)
	(list* (if (and attributes (some #'btl-string-p attributes))
		   `(,name ,@(btl-interpolate-attributes attributes))
		   (first element))
	       (btl-interpolate content)))
      element))

(defun btl-interpolate (content)
  (if (sometree #'btl-string-p content)
      (collecting
	(dolist (form content)
	  (cond
	    ((btl-string-p form)
	     (dolist (form (btl-interpolate-string form))
	       (etypecase form
		 (string (collect `(*ml ,form)))
		 (embedded-lisp (collect form)))))
	    ((consp form) (collect `(*ml ,(btl-interpolate-element object))))
	    (t (check-type object (or string symbol))
	       (collect `(*ml ,object))))))
      content))