(defpackage :php.parser
  (:use :cl :smug :serapeum :alexandria))

(in-package :php.parser)

'(:token (<token-type> *value))

(defmacro if-token (token &body body)
  (once-only (token)
    `(if (and (consp ,token)
	      (eq (car ,token)
		  :token))
	 (progn ,@body)
	 (error (format nil "~s is not a token" ,token)))))

(defun get-token-type (token)
  (if-token token
    (cadr token)))

(defun get-token-args (token)
  (if-token token
    (cddr token)))

(defmethod input-empty-p ((input null))
  t)

(defmethod input-empty-p ((input cons))
  nil)

(defmethod input-first ((input cons))
  (car input))

(defmethod input-rest ((input cons))
  (cdr input))

(defun .match-lexical-element (keyword)
  (.bind (.item)
	 (lambda (element)
	   (if (eq keyword
		   (car element))
	       (.identity element)
	       (.fail)))))

(defun .match-token (&optional type)
  (.let* ((matched-token (.match-lexical-element :token)))
    (if type
	(if (eq type (get-token-type matched-token))
	    (.identity matched-token)
	    (.fail))
	(.identity matched-token))))

(defun .match-keyword (&optional name)
  (.let* ((tok (.match-token :keyword)))
    (if name
	(if (equal name (get-token-args tok))
	    (.identity tok)
	    (.fail))
	(.identity tok))))

(defun .match-whitespace ()
  (.match-lexical-element :whitespace))

(defun .match-operator (&optional op)
  (.let* ((matched-op (.or (.match-token :operator)
			   (.match-token :punctuator)
			   (.match-token :paired-punctuator))))
    (if (or (not op) 
	    (equal (get-token-args matched-op)
		   op))
	(.identity matched-op)
	(.fail))))

(defun .match-punctuator (&optional sym)
  (.or (.match-unpaired-punctuator sym)
       (.match-paired-punctuator sym)))

(defun .match-unpaired-punctuator (&optional sym)
  (.let* ((punct (.match-token :punctuator)))
    (if (or (not sym)
	    (equal (get-token-args punct)
		   sym))
	(.identity punct)
	(.fail))))

(defun .match-paired-punctuator (&optional sym)
  (.let* ((punct (.match-token :paired-punctuator)))
    (if (or (not sym)
	    (equal (get-token-args punct)
		   sym))
	(.identity punct)
	(.fail))))

(defun .expression ()
  (.item))

(defun .parenthesized-expression ()
  (.prog2 (.match-paired-punctuator "(")
	  (.expression)
	  (.match-paired-punctuator ")")))

(defun .match-variable ()
  (.match-token :variable))

(defun qualified-name-arguments (qualified-name-token)
  (apply #'values (coerce (get-token-args qualified-name-token)
			  'list)))

(defun qualified-name-namespace (qualified-name-token)
  (nth-value 0 (qualified-name-arguments qualified-name-token)))

(defun qualified-name-name (qualified-name-token)
  (nth-value 1 (qualified-name-arguments qualified-name-token)))

(defun .match-qualified-name (&key (namespace nil namespace-p) name)
  (.let* ((matched-name (.match-token :qualified-name)))
    (if (or namespace-p name)
	(multiple-value-bind (uw-namespace uw-name) (qualified-name-arguments matched-name)
	  (cond ((and namespace-p (not (equal namespace uw-namespace)))
		 (.fail))
		((and name (not (equal name uw-name)))
		 (.fail))
		(t (.identity matched-name))))
	(.identity matched-name))))

(defun .match-name (&optional name)
  (.match-qualified-name :namespace nil :name name))

(defun .match-literal ()
  (.match-token :literal))



;;; Expressions

(defun .function-definition-header ()
  (.progn (.match-keyword "function")))

(defun .primary-expression ()
  (php.lexer::tag-result :expression
    (.or (.match-variable)
	 (.match-qualified-name)
	 (.match-literal)
	 (.constant-expression)
	 ;(.intrinsic)
	 ;(.anonymous-function-creation-expression)
	 ;(.parenthesized-expression)
	 )))

(defun .scalar-type ()
  (.or (.match-name "bool")
       (.match-name "float")
       (.match-name "int")
       (.match-name "string")))

; Add scalar-type / qualified-name
(defun .type-declaration ()
  (.or (.match-keyword "array")
       (.match-keyword "callable")
       (.scalar-type)
       (.match-qualified-name)))

(defun .parameter-declaration ()
  (php.lexer::tag-result :parameter-declaration
    (.let* ((declared-type (.optional (.type-declaration)))
	    (reference-marker (.optional (.match-operator "&")))
	    (variable-declaration (.match-variable))
	    (default-value (.optional
			    (.progn (.match-operator "=")
				    (.constant-expression)))))
      (.identity (list variable-declaration
		       :type declared-type
		       :is-reference (and reference-marker t)
		       :default-value default-value)))))

(defun .variadic-parameter ()
  (php.lexer::tag-result :variadic-parameter
    (.let* ((declared-type (.optional (.type-declaration)))
	    (reference-marker (.optional (.match-operator "&")))
	    (variable-declaration (.progn (.match-operator "...")
					  (.match-variable))))
      (.identity (list variable-declaration
		       :type declared-type
		       :is-reference (and reference-marker t))))))

(defun .simple-parameter-declaration-list ()
  (.or (.let* ((parameters (.first
			    (.map 'list (.prog1 (.parameter-declaration)
						(.match-unpaired-punctuator ","))
				  :at-least 0)))
	       (last-parameter (.parameter-declaration)))
	 (.identity (append parameters
			    (list last-parameter))))
       (.let* ((res (.parameter-declaration)))
	 (.identity (list res)))))

(defun .variadic-declaration-list ()
  (.let* ((normal-params (.optional (.simple-parameter-declaration-list)))
	  (variadic-param (.progn (.match-unpaired-punctuator ",")
				  (.variadic-parameter))))
    (.identity (append normal-params
		       (list variadic-param)))))

(defun .parameter-declaration-list ()
  (.or (.simple-parameter-declaration-list)
       (.variadic-declaration-list)))

(defun .return-type ()
  (.progn (.match-operator ":")
	  (.or (.match-qualified-name :name "void")
	       (.type-declaration))))

(defun .function-definition-header ()
  (php.lexer::tag-result :function-header
    (.progn (.match-keyword "function")
	    (.let* ((return-by-reference (.optional (.match-operator "&")))
		    (function-name (.match-name))
		    (parameters (.optional (.prog2 (.match-paired-punctuator "(")
						   (.parameter-declaration-list)
						   (.match-paired-punctuator ")"))))
		    (return-type (.optional (.return-type))))
	      (.identity
	       (list :function
		     :name function-name
		     :parameters parameters
		     :return-type return-type
		     :return-by-reference (not (null return-by-reference))))))))

(defun .function-definition ()
  (php.lexer::tag-result :function-definition
    (.let* ((header (.function-definition-header))
	    (body (.compound-statement)))
      (.identity
       (list header body)))))

(defun .array-element-initializer ()
  (flet ((.element-key () (.expression))
	 (.element-value () (.expression)))
    (.or (.let* ((key (.prog1 (.element-key)
			      (.match-operator "=>")))
		 (is-ref (.optional (.match-operator "&")))
		 (value (.element-value)))
	   (.identity (list key value :is-reference (and is-ref t))))
	 (.let* ((is-ref (.optional (.match-operator "&")))
		 (value (.element-value)))
	   (.identity (list value :is-reference (and is-ref t)))))))

(defun .array-initializer-list ()
  (.let* ((first (.array-element-initializer))
	  (rest (.map 'list (.progn (.match-punctuator)
				    (.array-element-initializer))
		      :at-least 0)))
    (.identity (cons first rest))))

(defun .array-initializer ()
  (.optional (.array-initializer-list)))

(defun .array-creation-expression ()
  (php.lexer::tag-result :array
    (.let* ((opening (.or (.progn (.match-keyword "array")
				  (.match-paired-punctuator "("))
			  (.match-paired-punctuator "[")))
	    (list (.array-initializer))
	    (closing  (.match-paired-punctuator
		       (if (string= "(" (get-token-args opening))
			   ")"
			   "]"))))
      closing
      (.identity list))))

(defun .constant-expression ()
  (.or (.array-creation-expression)
       (.expression)))

(defparameter *fun-tion*
  "function fib($x) {
  array_merge([1,2,3], [2,3,4]);
  if ($x == 0) return 1;
  if ($x == 1) return 1;
  if ($x >  1) return fib($x-1) + fib($x-2);
}")

(defparameter *function-tokens*
  (parse (php.lexer::.input-file)
	 *fun-tion*))

(defparameter *uut*
  (parse (php.lexer::.input-file)
	 "callable &$foo = array_merge([1,2,3], [4,5,6]);"))


(defvar *xml-output* (make-synonym-stream '*standard-output*))
(flet ((escape-cdata-end (string)
	 (string-replace-all "]]>" string "]]>]]&gt;<![CDATA[")))
  (defgeneric to-xml (tag)
    (:method ((tag cons))
      (format *xml-output* "~&<~(~a~)>~{~a~}</~(~a~)>~%"
	      (car tag)
	      (mapcar #'(lambda (x)
			  (with-output-to-string (*xml-output*)
			    (to-xml x)))
		      (cdr tag))
	      (car tag)))
    (:method ((tag integer))
      (format *xml-output* "<![CDATA[~a]]>" tag))

    (:method :around ((tag string))
	     (format *xml-output* "<![CDATA[~a]]>"
		     (call-next-method)))
    (:method ((tag string))
      (escape-cdata-end tag))))

(defmacro flip-values (form)
  `(multiple-value-bind (a b) ,form
     (values b a)))