(require (lib "string.ss"))
(require (lib "13.ss" "srfi"))
(require (lib "1.ss" "srfi"))


(define (make-action string) (lambda (input offset) (values `(anaction ,string) offset)))
(define (make-name string) (string->symbol (string-concatenate (list "parse_" string))))

(define (match-string string)
  (lambda (input offset)
    (let ((newoffset (+ (string-length string) offset)))
      (if (> newoffset (string-length input))
	  (values null null)
	  (if (string=? (substring input offset newoffset) string)
	      (values string newoffset)
	      (values null null))))))

(define (match-char char-list)
  (lambda (input offset)
    (if (> (+ offset 1) (string-length input))
	(values null null)
	(let ((char (first (string->list (substring input offset (+ offset 1))))))
	  (let loop ((cs char-list))
	    (if (null? cs)
		(values null null)
		(if (char=? char (car cs))
		    (values char (+ offset 1))
		    (loop (cdr cs)))))))))

(define (match-any-char ignored)
  (lambda (input offset)
    (if (> offset (string-length input))
	(values null null)
	(values (first (string->list (substring input offset (+ offset 1))))
		(+ offset 1)))))

(define (negate parser)
  (lambda (input offset)
    (let-values ([(result newoffset) (parser input offset)])
		(if (null? newoffset)
		    (values 'negate offset)
		    (values null null)))))

(define (either . parsers)
  (lambda (input offset)
    (let loop ((ps parsers))
      (begin
	(cond ((null? ps) (values null null))
	      (else (begin (let-values ([(result newoffset) ((car ps) input offset)])
				       (if (not (null? newoffset))
					   (values result newoffset)
					   (loop (cdr ps)))))))))))

(define-syntax  push
  (syntax-rules ()
    ((push item list)
     (set! list (cons item list)))))

(define (many parser)
  (lambda (input offset)
    (let ((children null)) (let loop ()
			     (let-values ([(result newoffset) (parser input offset)])
					 (if (not (null? newoffset))
					     (begin
					       (push result children)
					       (set! offset newoffset)
					       (loop))
					     (values (reverse children) offset)))))))

(define (many1 parser)
  (lambda (input offset)
    (let-values ([(result newoffset) (parser input offset)])
		(if (not (null? newoffset))
		    (let-values ([(result2 newoffset2) ((many parser) input newoffset)])
				(if (not (null? newoffset2))
				    (values (cons result result2) newoffset2)
				    (values result newoffset)))
		    (values null null)))))

(define (seq . parsers)
  (lambda (input offset)
    (let ((children null))
      (let loop ((ps parsers))
	(if (null? ps)
	    (values (reverse children) offset)
	    (let-values ([(result newoffset) ((car ps) input offset)])
			(if (not (null? newoffset))
			    (begin
			      (push result children)
			      (set! offset newoffset)
			      (loop (cdr ps)))
			    (values null null))))))))

(define (char-list-to-string char-list)
  (apply string char-list))

(define (make-scheme-call-rule-closure rule)
  `(lambda (input offset)
     (((,rule)) input offset)))

(define (make-call-rule-closure rule)
  `(lambda (input offset)
     (,rule input offset)))

(define (fix-escapes char-list)
  (do ((out null)
       (remaining char-list))
      ((null? remaining) (reverse! out))
    (let ((c (first remaining)))
;      (printf "rem ~s~n" remaining)
      (if (char=? c #\\)
	  (let ((nextc (second remaining)))
	    (set! out (cons (case nextc
			      ((#\n) #\newline)
			      ((#\t) #\tab)
			      (else nextc))
			    out))
	    (set! remaining (cdr (cdr remaining))))
	  (begin 
	    (set! out (cons c out))
	    (set! remaining (cdr remaining)))))))

(define (zip-second pair-list)
  (let-values ([(fst snd) (unzip2 pair-list)])
	      snd))

(define (write-parser-to-file form filename)
  (if (file-exists? filename)
      (delete-file filename))
  (let ((port (open-output-file filename)))
    (write form port)
    (close-output-port port)))

(define (read-file filename)
  (let* ((size (file-size filename))
	(file (open-input-file filename))
	(s (read-string size file)))
    (close-input-port file)
    s))

(define (transform tree)
  (define (find-action node-list)
    (cond ((null? node-list) #f)
	  ((and (pair? (car node-list))
		(eq? (car (car node-list)) 'anaction))
	   (eval (read-from-string (string-concatenate (list "(lambda (data) " (cadr (car node-list)) ")")))))
	  (else (find-action (cdr node-list)))))
  
  (if (pair? tree)
      (if (eq? (first tree) 'anaction)
	  tree
	  (let* ((data (map transform tree))
		 (func (find-action data)))
	    (if (procedure? func)
		(let ((result (func data)))
;		  (printf "func ~s result ~s~n" func result)
		  result)
		(begin
;		  (printf "not a func ~s~n" func)
		data))))
      tree))
		

(define (parse input-file-name parser-file)
  (load parser-file)
  (let ((input (read-file input-file-name)))
    (transform 
     (let-values ([(result offset) (parser input 0)])
		 result))))