;; #### Core implementation ####

(defclass face ()
  ((name :initarg :name)
   (bold :initarg :bold)
   (underline :initarg :underline)
   (foreground :initarg :foreground)
   (background :initarg :background)
   (subfaces :initarg :subfaces)))


;; #### Functional wrappers ####

(defun make-face (name &rest args &key &allow-other-keys)
  (apply #'make-instance 'face :name name args))

(defun make-theme (&rest args)
  (apply #'make-face 'toplevel args))


;; #### MOP Extension ####

(defun extract-faces (keys)
  (loop :for (key val) :on keys :by #'cddr
	:when (eq key :face)
	  :collect val))

(defmethod initialize-instance ((instance face) &rest args &key face)
  (declare (ignore face))
  (apply #'call-next-method instance :subfaces (extract-faces args) args))


;; #### Macros ####

(defmacro define-face (name &rest options)
  `(make-face ',name
	      ,@(loop :for (key val) :on options :by #'cddr
		      :collect key
		      :if (member key '(:face :subfaces))
			:collect val
		      :else
			:collect `',val)))

(defmacro define-theme (&rest args)
  `(define-face toplevel ,@args))


;; #### Reader Extensions ####

(defun |{-reader| (stream char)
  (declare (ignore char))
  (let ((make-face-arguments (read-delimited-list #\} stream t)))
    (push 'define-face make-face-arguments)))

(set-macro-character #\{ #'|{-reader|)
(set-macro-character #\} (get-macro-character #\))) ;; not necessary


;; #### Externalization ####

(defun read-user-theme ()
  (with-open-file (stream (merge-pathnames ".faces" (user-homedir-pathname)))
    (read (make-concatenated-stream (make-string-input-stream "(define-theme ")
				    stream
				    (make-string-input-stream ")")))))

(defmacro make-user-theme (&optional compile)
  (if compile
      `(funcall (compile nil (lambda () ,(read-user-theme))))
      (read-user-theme)))


;; #### Internalization ####

(setq default-theme
      (define-theme
	  :background black
	  :face { option :foreground white
			 :face { syntax :bold t :foreground cyan }
			 :face { usage :foreground yellow }
		}
	))