(require 'cl)

;;; file access

(defun read-file (name)
  (let ((buf (generate-new-buffer "infile"))
	(res nil))
    (save-excursion
      (set-buffer buf)
      (insert-file-contents name)
      (condition-case nil
	  (while t
	    (setq res (cons (read buf) res)))
	(end-of-file (reverse res))))))

(defun setup-outfile ()
  (setq standard-output (generate-new-buffer "outfile")))

(defun write-outfile (name)
  (save-excursion
    (set-buffer standard-output)
    (write-region (point-min) (point-max) name)))

;;; string stunts

(defun char-upper-case-p (ch)
  (eql (upcase ch) ch))

(defun char-lower-case-p (ch)
  (eql (downcase ch) ch))

(defun canonicalize (str)
  (if (symbolp str)
      (setq str (symbol-name str)))
  (let ((res nil)
	(start 0)
	(pos 0)
	(end (length str))
	(prevlower nil))
    (while (< pos end)
      (let ((ch (elt str pos)))
	(cond ((memq ch '(?- ?_))
	       (setq res (cons (substring str start pos) res)
		     prevlower nil
		     pos (1+ pos)
		     start pos))
	      ((and (char-upper-case-p ch)
		    prevlower)
	       (setq res (cons (substring str start pos) res)
		     start pos
		     pos (1+ pos)
		     prevlower nil))
	      (t
	       (setq pos (1+ pos)
		     prevlower (char-lower-case-p ch))))))
    (reverse (mapcar 'downcase (cons (substring str start end) res)))))

(defun syllables-to-string (syls del)
  (let ((res ""))
    (while syls
      (setq res (format "%s%s%s" res (car syls)
			(if (cdr syls) del ""))
	    syls (cdr syls)))
    res))

(defun macroname (canon)
  (syllables-to-string (mapcar 'upcase canon) "_"))

(defun funcname (canon)
  (syllables-to-string canon "_"))

(defun typename (canon)
  (syllables-to-string (mapcar 'capitalize canon) ""))

(defun scmname (canon)
  (syllables-to-string canon "-"))

(defun short-name (canon)
  (if (equal (car canon) "gtk") (cdr canon) canon))

;;; Code generation

(defun printf (&rest args)
  (princ (apply 'format args)))

(defun interestingp (form)
  (and (listp form)
       (memq (car form) '(define-enum define-flags define-boxed))))

(defun map-interesting (func defs)
  (mapcar #'(lambda (form)
	      (if (interestingp form)
		  (funcall func form)))
	  defs))

(defun emit-idmacs (defs)
  (let ((i 0))
    (map-interesting 
     #'(lambda (form)
	 (let ((name (canonicalize (cadr form))))
	   (printf "#define GTK_TYPE_%s (gtk_type_builtins[%d])\n"
		   (macroname (short-name name)) i))
	 (setq i (1+ i)))
     defs)
    (printf "#define GTK_TYPE_NUM_BUILTINS %d\n" i)))

(defun emit-ids (defs)
  (map-interesting
   #'(lambda (form)
       (printf "  { %S, %s },\n"
	       (symbol-name (cadr form))
	       (case (car form)
		 ((define-enum) "GTK_TYPE_ENUM")
		 ((define-flags) "GTK_TYPE_FLAGS")
		 ((define-boxed) "GTK_TYPE_BOXED"))))
   defs))

       
       
(if (< (length command-line-args-left) 3)
    (error "args: op def-file output-file"))

(setq op (intern (car command-line-args-left)))
(setq defs (read-file (cadr command-line-args-left)))
(setq outfile (caddr command-line-args-left))
(setq command-line-args-left nil)

(setup-outfile)
(printf "/* generated by gentypeinfo from \"gtk.defs\" */\n\n")
(case op
  ((idmac)
   (emit-idmacs defs))
  ((id)
   (emit-ids defs))
  (else
   (error "supported ops are: idmac id")))
(write-outfile outfile)