compile.lisp

(in-package #:hecss)

(defclass css-compiler ()
  ())

(defun compile-css (compiler element)
  (css-compile compiler element))

(defgeneric css-compile (compiler element))

(defmethod css-compile ((compiler css-compiler) anything)
  #'(lambda (renderer stream)
      (css-render renderer anything stream)))

(defun call-in-sequence (functions)
  (if functions
      (let ((call (car functions))
	    (call-rest (call-in-sequence (cdr functions))))
	#'(lambda (&rest args)
	    (apply call args)
	    (apply call-rest args)))
      (lambda (&rest ignored)
	(declare (ignore ignored))
	(values))))

(defmethod css-compile ((compiler css-compiler) (rules list))
  (call-in-sequence (mapcar (lambda (rule)
			      (let ((compiled (css-compile compiler rule)))
				#'(lambda (renderer stream)
				    (funcall compiled renderer stream)
				    (terpri stream))))
			    rules)))

(defmethod css-compile ((compiler css-compiler) (import css-import))
  (let ((compiled-target (css-compile compiler (css-import-target import)))
	(compiled-medias (mapcar (fmask #'css-compile ? (compiler ?))
				 (css-import-media-types import))))
    #'(lambda (renderer stream)
	(princ "@import \"" stream)
	(funcall compiled-target renderer stream)
	(princ #\" stream)
	(when compiled-medias
	  (princ " " stream)
	  (funcall (first compiled-medias) renderer stream)
	  (dolist (compiled-media (cdr compiled-medias))
	    (princ ", " stream)
	    (funcall compiled-media renderer stream)))
	(princ ";" stream))))

(defmethod css-compile ((compiler css-compiler) (rule css-rule))
  (let ((selector-renderers (mapcar (fmask #'css-compile ? (compiler ?))
				    (rule-selectors rule)))
	(declaration-renderers (mapcar (fmask #'css-compile ? (compiler ?))
				       (rule-declarations rule))))
    #'(lambda (renderer stream)
	(funcall (first selector-renderers) renderer stream)
	(dolist (selector (cdr selector-renderers))
	  (princ ", " stream)
	  (funcall selector renderer stream))
	(princ "  {" stream)
	(dolist (dec declaration-renderers)
	  (format stream "~%    ")
	  (funcall dec renderer stream))
	(format stream "~%}"))))

(defmethod css-compile ((compiler css-compiler) (sel css-simple-selector))
  (let* ((type (simple-selector-type sel))
	 (specifiers (simple-selector-specifiers sel))
	 (specifiers-renderer
	  (call-in-sequence (mapcar (fmask #'css-compile ? (compiler ?))
				    specifiers))))
    (if (or (string/= type "*")
	    (not specifiers))
	(lambda (renderer stream)
	  (write-string type stream)
	  (funcall specifiers-renderer renderer stream))
	(lambda (renderer stream)
	  (funcall specifiers-renderer renderer stream)))))

(defmethod css-compile ((compiler css-compiler) (sel css-id-selector))
  (let ((rendered (format nil "#~A" (id-selector-id sel))))
    (make-string-renderer rendered)))

(defmethod css-compile ((compiler css-compiler) (sel css-class-selector))
  (let ((rendered (format nil ".~A" (class-selector-name sel))))
    (make-string-renderer rendered)))

(defmethod css-compile ((compiler css-compiler) (sel css-pclass-selector))
  (let ((rendered (format nil ":~A" (pclass-selector-name sel))))
    (make-string-renderer rendered)))

(defmethod css-compile ((compiler css-compiler) (sel css-attribute-selector))
  (let ((attribute (attribute-selector-attribute sel))
	(type (attribute-selector-type sel)))
    (if (eq type :set)
	(make-string-renderer (format nil "[~A]" attribute))
	(let ((prologue (format nil "[~A~A\"" attribute (attribute-selector-type-operator type)))
	      (compiled-operand (css-compile compiler (attribute-selector-operand sel))))
	  #'(lambda (renderer stream)
	      (princ prologue stream)
	      (funcall compiled-operand renderer stream)
	      (princ "\"]" stream))))))

(defmethod css-compile ((compiler css-compiler) (sel css-compound-selector))
  (let ((left-selector-renderer (css-compile compiler (left-selector sel)))
	(right-selector-renderer (css-compile compiler (right-selector sel)))
	(operator (compound-selector-traditional-relation-string
		   (compound-selector-relation sel))))
    #'(lambda (renderer stream)
	(funcall left-selector-renderer renderer stream)
	(princ operator stream)
	(funcall right-selector-renderer renderer stream))))

(defmethod css-compile ((compiler css-compiler) (dec css-declaration))
  (let ((value-renderer (css-compile compiler (declaration-value dec)))
	(attribute-prefix (format nil "~A: " (declaration-property dec))))
    #'(lambda (renderer stream)
	(princ attribute-prefix stream)
	(funcall value-renderer renderer stream)
	(princ ";" stream))))

(defmethod css-compile ((compiler css-compiler) (css-list css-list))
  (let ((list (mapcar (fmask #'css-compile ? (compiler ?))
		      (css-list-elements css-list)))
	(separator (ecase (css-list-type css-list)
		     (:space " ")
		     (:comma ", "))))
    #'(lambda (renderer stream)
	(when list
	  (funcall (car list) renderer stream)
	  (dolist (element (cdr list))
	    (princ separator stream)
	    (funcall element renderer stream))))))

(defmethod css-compile ((compiler css-compiler) (string string))
  (make-string-renderer string))

(defun make-string-renderer (string)
  #'(lambda (renderer stream)
      (declare (ignore renderer))
      (princ string stream)))