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

;(require "reader.ss")
(require "pretty-printer.ss")

(define (make-ctx input start-index) (list 'metapeg_node
					   input 
					   null ; parent
					   null ; rule
					   null ; children
					   null ; value
					   start-index
					   null ; end-index
))

(define (clone-ctx ctx rule) (begin
;			       (printf "cloning ctx ~a ~a for ~a ~n" (ctx-rule ctx) (ctx-end-index ctx) rule)
			       (list 'metapeg_node
				     (ctx-input ctx)
				     ctx
				     rule
				     null
				     null
				     (ctx-end-index ctx)
				     null)))

(define (ctx-input ctx) (second ctx))
(define (ctx-parent ctx) (third ctx))
(define (ctx-rule c) (fourth c))
(define (ctx-children c) (fifth c))
(define (ctx-value c) (sixth c))
(define (ctx-start-index c) (seventh c))
(define (ctx-end-index c) (eighth c))
(define (ctx-failed? ctx) (null? (ctx-end-index ctx)))

(define (succeed ctx value start-index end-index) 
  (set! (car (cdr (cddddr ctx))) value) ;aargh! set the ctx-value
  (set! (car (cddr (cddddr ctx))) start-index) ; seventh
  (set! (car (cdddr (cddddr ctx))) end-index) ;eighth
  ctx)

(define (fail) (list null null null null null null null null))

(define (make-glyph-action2 string) `(list 'glyphaction ,(let* ((input (string-concatenate (list "(lambda (data) " string ")")))
                                                                (result (read-from-string input)))
                                                           result)))
							   
(define (make-name string) (string->symbol (string-concatenate (list "parse_" string))))

(define (match-string string)
  (lambda (pctx offset)
    (let ((input (ctx-input pctx))
	  (ctx (clone-ctx pctx 'mp_string)))
      (let ((newoffset (+ (string-length string) offset)))
	(if (> newoffset (string-length input))
	    (fail)
	    (if (string=? (substring input offset newoffset) string)
		(succeed ctx string offset newoffset)
		(fail)))))))

(define (match-char char-list)
  (lambda (pctx offset)
    (let ((input (ctx-input pctx))
	  (ctx (clone-ctx pctx 'mp_char)))
      (if (> (+ offset 1) (string-length input))
	  (fail)
	  (let ((char (first (string->list (substring input offset (+ offset 1))))))
	    (let loop ((cs char-list))
	      (if (null? cs)
		  (fail)
		  (if (char=? char (car cs))
		      (succeed ctx char offset (+ offset 1))
		      (loop (cdr cs))))))))))

(define (match-any-char ignored)
  (lambda (pctx offset)
    (let ((input (ctx-input pctx))
	  (ctx (clone-ctx pctx 'mp_any_char)))
      (if (> offset (string-length input))
	  (fail)
	  (succeed ctx (first (string->list (substring input offset (+ offset 1))))
		   offset
		   (+ offset 1))))))

(define (negate parser)
  (lambda (pctx offset)
    (let* ((ctx (clone-ctx pctx 'mp_negate))
	   (result-ctx (parser ctx offset)))
      (if (ctx-failed? result-ctx)
	  (succeed ctx null offset offset)
	  (fail)))))

(define (either . parsers)
  (lambda (pctx offset)
    (let ((input (ctx-input pctx))
	  (ctx (clone-ctx pctx 'mp_either)))
      (let loop ((ps parsers))
	(begin
	  (cond ((null? ps) (fail))
		(else (begin 
			(let* ((result-ctx ((car ps) ctx offset))
			       (result (ctx-value result-ctx))
			       (newoffset (ctx-end-index result-ctx)))
			  (if (not (null? newoffset))
			      (succeed ctx result offset  newoffset)
			      (loop (cdr ps))))))))))))

(define (many parser)
  (lambda (pctx offset)
    (let ((children null)
	  (start-offset offset)
	  (ctx (clone-ctx pctx 'mp_many)))
      (let loop ()
	(let* ((result-ctx (parser ctx offset))
	       (result (ctx-value result-ctx))
	       (newoffset (ctx-end-index result-ctx)))
	  (if (not (null? newoffset))
	      (begin
		(set! children (cons result children))
		(set! offset newoffset)
		(loop))
	      (succeed ctx (reverse children) start-offset  offset)))))))

(define (many1 parser)
  (lambda (pctx offset)
    (let* (
	   (ctx (clone-ctx pctx 'mp_many1))
	   (result-ctx (parser ctx offset))
	   (result (ctx-value result-ctx))
	   (newoffset (ctx-end-index result-ctx)))
      (if (not (null? newoffset))
	  (let* ((ctx2 ((many parser) ctx newoffset))
		 (result2 (ctx-value ctx2))
		 (newoffset2 (ctx-end-index ctx2)))
	    (if (not (null? newoffset2))
		(succeed ctx (cons result result2) offset newoffset2)
		(succeed ctx result offset newoffset)))
	  (fail)))))

(define (optional parser)
  (lambda (pctx offset)
    (let* (
	   (ctx (clone-ctx pctx 'mp_optional))
	   (result-ctx (parser ctx offset))
	   (result (ctx-value result-ctx))
	   (newoffset (ctx-end-index result-ctx)))
      (if (not (null? newoffset))
	  (succeed ctx result offset newoffset)
	  (succeed ctx null offset offset)))))

(define (glyph-seq . parsers)
  (lambda (pctx offset)
    (let ((child-values null)
	  (child-nodes null)
	  (transformer null)
	  (start-offset offset)
	  (input (ctx-input pctx))
	  (ctx (clone-ctx pctx 'mp_seq)))
; find transformer
      (let loop ((ps parsers))
	(if (null? ps)
	    null
	    (if (and (pair? (car ps))
		     (eq? (car (car ps)) 'glyphaction))
		(set! transformer (cadar ps))
		(loop (cdr ps)))))
; now run the parsers
      (let loop ((ps parsers))
	(if (null? ps)
	    (if (null? transformer)
		(succeed ctx (reverse child-values) start-offset offset)
		(begin
;		  (printf "transformer ~a on ~s~n" transformer (reverse children))
		  (succeed (clone-ctx ctx 'mp_seq) (transformer (map 
						  (lambda (item)
						    (if (and (pair? item)
							     (eq? (first item) 'metapeg_node))
							(ctx-value item)
							item))
						  (reverse child-values))) start-offset offset))) ; run the transformer if it was found
	    (if (pair? (car ps))
		(loop (cdr ps))
		(let* ((result-ctx ((car ps) ctx offset))
		       (result (ctx-value result-ctx))
		       (newoffset (ctx-end-index result-ctx)))
		  (if (not (null? newoffset))
		      (begin
;			(printf "in seq ~s ~a~n" result newoffset)
			(set! child-values (cons result child-values))
			(set! offset newoffset)
			; update the child NODES in the parent context (fifth elt)
			;(set! (ctx-children ctx) (reverse children))
			(set! child-nodes (cons result-ctx child-nodes))
			(set! (car (cddddr ctx)) (reverse child-nodes))
			(loop (cdr ps)))
		      (fail)))))))))

(define (match rule-name)
  (lambda (pctx offset)
    (find-match pctx (ctx-parent pctx) rule-name offset)))

(define (find-match original-ctx examine-ctx rule-name offset)
  (if (null? examine-ctx)
      (begin
	(succeed (clone-ctx original-ctx rule-name) "" offset offset))
      (let ((siblings (ctx-children examine-ctx)))
;	(printf "siblings ~a~n" siblings)
	(let loop ((sibs siblings))
	  (if (null? sibs)
	      (find-match original-ctx (ctx-parent examine-ctx) rule-name offset)
	      (let ((sib (car sibs)))
		(if (and (eq? (car sib) 'metapeg_node)
			 (string? (ctx-rule sib))
			 (string=? (ctx-rule sib) rule-name))
		    (let* ((ms (substring (ctx-input sib) (ctx-start-index sib) (ctx-end-index sib)))
			   (failed (null? (ctx-end-index ((match-string ms) sib offset)))))
		      (if failed
			  (fail)
			  (succeed (clone-ctx original-ctx rule-name) ms offset (+ offset (string-length ms)))))
		    (loop (cdr sibs)))))))))

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

(define (make-scheme-call-rule-closure2 rule)
  `(lambda (ctx offset)
     (((,rule)) ctx offset)))

(define (fix-escapes2 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 ((accum null))
    (let loop ((pairs pair-list))
      (if (null? pairs)
	  (reverse accum)
	  (begin
	    (set! accum (cons (second (car pairs)) accum))
	    (loop (cdr pairs)))))))

(define (write-parser-to-file form filename)
  (if (file-exists? filename)
      (delete-file filename))
  (let ((port (open-output-file filename)))
    (pretty-print 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 (parse-glyph input-file-name parser-file)
  (load parser-file)
  (let* ((input (read-file input-file-name))
	 (ctx (parser (make-ctx input 0) 0))
	 (result (ctx-value ctx)))
    result))

(define (parse-glyph2 input-file-name parser-file)
  (load parser-file)
  (let* ((input (read-file input-file-name)))
	 (parser (make-ctx input 0) 0)))