;; grammar.lisp

(defpackage :grammar
  (:use :cl)
  (:export :compile-grammar :def-grammar :emit-php))

(in-package :grammar)


;;; environment access

(defstruct environment
  name 
  (gensym-count 0)
  (functions nil))

(defvar *environment*)

(defun anonymous-function-name ()
  "Return a symbol suitable to use as a unique function in the current
*ENVIRONMENT*."
  (intern (format nil "~A~4,'0D"
                  (environment-name *environment*)
                  (incf (environment-gensym-count *environment*)))))


;;;

(defun compile-function (name body)
  "Compile BODY and enter it into *ENVIRONMENT* with NAME."
  (let ((converted-body (cons (car body)
                              (mapcar #'convert-argument (cdr body)))))
    (push (cons name converted-body)
          (environment-functions *environment*))))

(defun compile-function/anonymous (body)
  "Compile a body into a function and return its newly generated name."
  (let ((name (anonymous-function-name)))
    (compile-function name body)
    name))

(defun convert-argument (arg)
  "Convert a single argument to an atom."
  (if (consp arg)
      (compile-function/anonymous arg)
      arg))


;;; grammars
(defun rule-name (rule)
  (first rule))

(defun rule-body (rule)
  (cadr rule))

(defun compile-grammar (name rules)
  "Convert RULES to an environment object."
  (let ((*environment* (make-environment :name name)))
    (dolist (rule rules)
      (compile-function (rule-name rule) (rule-body rule)))
    *environment*))



;;; emitting functions

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro def-php-function (name (args stream) &body body)
    `(eval-when (:compile-toplevel :load-toplevel :execute)
      (setf (get ',name 'php-function)
       (lambda (,args ,stream) ,@body)))))

(defun symbol->php-name (symbol)
  "Return SYMBOL converted to a string suitable for use as a function
name, prepended with the name of *ENVIRONMENT*. As a special case, symbols that start with #\\@ are converted without a prefix, but with #\\@ removed."
  (let* ((symbol-name (symbol-name symbol))
         (environment-name (symbol-name (environment-name *environment*)))
         (name (if (char= (schar symbol-name 0) #\@)
                   (string-downcase (subseq symbol-name 1))
                   (format nil "~(~A__~A~)" environment-name symbol-name))))
    (substitute-if #\_ (complement #'alphanumericp) name)))


(defun php-arg->string (arg)
  "Return ARG converted to a string suitable for a PHP function
argument list. Symbols are converted to function calls, and strings
are surrounded with double quotes."
  (etypecase arg
    (symbol
     (format nil "~A()" (symbol->php-name arg)))
    (string
     (format nil "\"~A\"" arg))))


(def-php-function join (args stream)
  (write-string "return join(\" \", Array(" stream)
  (format stream "~{~A~^, ~}" (mapcar #'php-arg->string args))
  (write-line "));" stream))

(def-php-function random (args stream)
  (let ((n-choices (1- (length args))))
    (format stream "switch (rand(0, ~D)) {~%" n-choices)
    (loop for i from 0
          for form in args
          do
          (format stream "case ~D:~%" i)
          (format stream "return ~A;~%" (php-arg->string form))
          (format stream "break;~%"))
    (format stream "}~%")))

(def-php-function sprintf (args stream)
  (let ((format-string (car args))
        (format-args (cdr args)))
    (format stream "return sprintf(\"~A\", ~{~A~^, ~});~%"
            format-string (mapcar #'php-arg->string format-args))))


(defun rule-function (symbol)
  "Return the Lisp rule function for SYMBOL, if it exists, regardless
of SYMBOL's initial package."
  (get (intern (symbol-name symbol)
               (find-package "GRAMMAR"))
       'php-function))


(defun emit-php-function (name body stream)
  "Write the expansion of the PHP function named NAME with a body of
BODY to STREAM."
  (format stream "function ~A() {~%" (symbol->php-name name))
  (format stream "# ~A => ~S~%" name body)
  (let* ((body-function (car body))
         (body-args (cdr body))
         (body-emitter-function (rule-function body-function)))
    (if body-emitter-function
        (funcall body-emitter-function body-args stream)
        (error "~A -- unknown php function" body-function)))
  (format stream "}~%~%"))
    
  


(defun emit-php (environment stream)
  "Convert an environment object to PHP text, writing out to STREAM."
  (let ((*environment* environment)
        (*print-pretty* nil))
    (dolist (function (environment-functions environment))
      (emit-php-function (car function) (cdr function) stream))))
    


;;; macro to make this all pretty and declarative

(defmacro def-grammar (name &body rules)
  `(let ((environment (compile-grammar ',name ',rules)))
    (defun ,name (file)
      (with-open-file (stream file :direction :output :if-exists :supersede)
        (format stream "<?~%")
        (emit-php environment stream)))))