(in-package :metapeg)

; Global variables used during the parse
; --------------------

(defvar *rules* nil)
(defvar *debug* nil)
(defvar *input* nil)

; Utility functions
; --------------------

(defun make-name (string) (intern (concatenate 'string "parse_" string) (find-package :cl-user)))

; this is a clunky way of looking for an escape (#\\) and doing something special to the following char
; the two chars are then replaced by the new one
(defun fix-escapes (char-list)
  (loop while (let ((pos (position #\\ char-list :test #'equal)))
		(if pos
		    (let ((escape-char (elt char-list (+ pos 1))))
		      (setf char-list (concatenate 'list
						   (subseq char-list 0 pos)
						   (string (case escape-char
							     (#\t #\Tab)
							     (#\n #\Newline)
							     (t escape-char)))
						   (subseq char-list (+ pos 2))))
		      t)
		    nil)))
  char-list)

; filter out the first part of pair, useful for patterns where we specify a negative match (eg (!"x" .)*)
(defun zip-second (pair-list)
  (loop for (fst snd) in pair-list collect snd))

(defun make-call-rule-closure (rule)
  `#'(lambda (offset) (funcall (cadr (assoc ',rule *rules*)) offset)))

(defun call-rule (rule)
  (make-call-rule-closure rule))

(defun char-list-to-string (char-list)
  (reduce #'(lambda (a b) (concatenate 'string a (string b))) char-list :initial-value ""))

(defun write-parser-to-file (form filename)
  (with-open-file (stream filename :direction :output :if-exists :supersede)
    (let ((*print-readably* t))
      (prin1 form stream))))

; parsing combinator functions
; --------------------

; I have found remarkably elegant recursive versions of these combinators
; but this comment block is too small to note them

(defun either (&rest parsers)
  #'(lambda (offset)
      (block b1
	(loop for p in parsers
	      do (multiple-value-bind (result newoffset) (funcall p offset)
		   (if (not (null newoffset) ) 
		       (progn
			 (return-from b1 (values result newoffset))))))
	(values nil nil))))


(defun many (parser) #'(lambda (offset)
			 (block b1
			   (let (children)
			     (loop do
				   (multiple-value-bind (result newoffset) (funcall parser offset)
				     (if newoffset
					 (progn
					   (push result children)
					   (setf offset newoffset))
					 (return-from b1 (values (reverse children) offset)))))))))


(defun many1 (parser) #'(lambda (offset)
			  (multiple-value-bind (result newoffset) (funcall parser offset)
			    (if newoffset
				(multiple-value-bind (result2 newoffset2) (funcall (many parser) newoffset)
				  (if newoffset2
				      (values (cons result result2) newoffset2)
				      (values result newoffset)))
				(values nil nil)))))

(defun seq (&rest parsers)
  #'(lambda (offset)
      (block b1
	(let (children)
	  (loop for p in parsers do
		(multiple-value-bind (result newoffset) (funcall p offset)
		  (if newoffset
		      (progn
			(push result children)
			(setf offset newoffset))
		      (return-from b1 (values nil nil))))
		finally (progn
			  (return (values (reverse children) offset))))))))

; non-portable use of bounding exception, should check input length instead

(defun match-string (string)
  #'(lambda (offset)
      (handler-case (if (string-equal string (subseq *input* offset (+ offset ( length string))))
	  (progn
;	    (format t "matched ~A ~A~%" offset string)
	    (values string (+ offset (length string))))
	  (values nil nil))
	(SB-KERNEL:BOUNDING-INDICES-BAD-ERROR (e) (values nil nil)))))

(defun match-char (char-list)
  #'(lambda (offset)
      (handler-case
	  (block b1
	    (loop for char in char-list do
		  (if (equal char (elt *input* offset))
		      (return-from b1 (values char (+ offset 1)))))
	    (values nil nil))
	(SB-KERNEL:BOUNDING-INDICES-BAD-ERROR (e)
	  (values nil nil))
	(SB-KERNEL::INDEX-TOO-LARGE-ERROR) (e1) (values nil nil))))


(defun match-any-char (ignored)
  #'(lambda (offset)
      (handler-case
	  (values (subseq *input* offset (+ offset 1)) (+ offset 1))
	(SB-KERNEL:BOUNDING-INDICES-BAD-ERROR (e)
	   (values nil nil)))))

(defun negate (parser)
  #'(lambda (offset)
      (multiple-value-bind (result newoffset) (funcall parser offset)
	(if newoffset
	    (values nil nil)
	    (values 'negate offset))))) ;note we return a parse result but don't advance input

(defun make-action (string)
  #'(lambda (offset)
      (values `(anaction ,string) offset)))

; Tree transformation
; --------------------


; processes a tree looking for lists starting with 'anaction
; the string part of the action is read and evaluated as a function, passing its siblings as the data parameter
; in this way parts of the tree are transformed by these actions

(defun transform (tree)
  (if tree
      (if (listp tree)
	  (if (equal (first tree) 'anaction)
	      tree
	      (let ((data (map 'list #'transform tree)))
		(progn (loop for el in data
			  when (and (listp el)
				    (equal (first el) 'anaction))
			  do (let ((func (read-from-string (concatenate 'string "#'(lambda (data) " (second el) ")"))))
			       (if cl-user::*debug*
				   (format t "func ~A data ~A~%" func data))
			       (return-from transform (funcall (eval func) data))))
		       data)))
	  tree)))

(defun read-file (filename)
  (with-open-file (file filename :direction :input)
    (let ((s (make-string (file-length file))))
      (read-sequence s file)
      s)))

(defun parse (grammar-file lisp-file)
  (let ((*input* (read-file grammar-file))) (transform (eval (read-from-string (read-file lisp-file))))))