;; OMeta Library
;;
;; Copyright (c) 2008 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
;; Copyright (c) 2008 LShift Ltd. <query@lshift.net>
;; 
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;; Requires: SRFI-1, SRFI-9, SRFI-13, SRFI-69. See the documentation for more
;; details.

;; FIXME: move to wrapper
(require (lib "errortrace.ss" "errortrace"))
(require (lib "pretty.ss"))
(require (all-except (lib "1.ss" "srfi") reverse! member map for-each assoc append!)
	 (lib "9.ss" "srfi")
	 (all-except (lib "13.ss" "srfi") string-hash)
	 (lib "69.ss" "srfi")
	 (lib "include.ss"))

;; A parse position is a path. The tip of the path changes as we
;; consume tokens. Recursive parses push a new tip onto the path.
;; For files, a path tip is a (filename line column) triple.
;; Tips must be lists, strings, or numbers.
;; Lists have their most-significant element first.

(define *ometa-debug* #f)

;; false < numbers < strings < empty-list < list < true
(define (parse-position-type-index x)
  (cond
   ((not x) 0)
   ((number? x) 1)
   ((string? x) 2)
   ((null? x) 3)
   ((pair? x) 4)
   ((eq? x #t) 5)
   (else (error "Invalid parse-position" x))))

(define parse-position-type-predicates
  (vector (lambda (a b) #f)
	  >
	  string>?
	  (lambda (a b) #f)
	  (lambda (a b)
	    (cond
	     ((parse-position>? (car a) (car b)) #t)
	     ((parse-position>? (car b) (car a)) #f)
	     (else (parse-position>? (cdr a) (cdr b)))))
	  (lambda (a b) #f)))

(define (parse-position>? a b)
  (let ((ta (parse-position-type-index a))
	(tb (parse-position-type-index b)))
    (cond
     ((> ta tb) #t)
     ((< ta tb) #f)
     (else ((vector-ref parse-position-type-predicates ta) a b)))))

(define (top-file-parse-position filename)
  (list filename 1 0))

(define (update-file-parse-position pos ch)
  (case ch
    ((#\return) (list (car pos) (cadr pos) 0))
    ((#\newline) (list (car pos) (+ (cadr pos) 1) 0))
    ((#\tab) (list (car pos) (cadr pos) (* (quotient (+ (caddr pos) 8) 8) 8)))
    (else (list (car pos) (cadr pos) (+ (caddr pos) 1)))))

(define (pretty-printN . xs)
  (pretty-print xs)
  (last xs))

;; A parse error is a pair of position-path and lset of error reports.
;; (<position> . (<error-report> ...))
(define (merge-parse-errors e1 e2)
  ;;(pretty-printN `(merge ,e1 ,e2)
  (cond
   ((not e1) e2)
   ((not e2) e1)
   (else (let ((p1 (car e1))
	       (p2 (car e2)))
	   (cond
	    ((or (parse-position>? p1 p2) (null? (cdr e2))) e1)
	    ((or (parse-position>? p2 p1) (null? (cdr e1))) e2)
	    (else (cons p1 (lset-union equal? (cdr e1) (cdr e2)))))))))
  ;;)

(define (merge-success prev-err ks)
  (lambda (sv new-env next err)
    (ks sv new-env next (merge-parse-errors err prev-err))))

(define (merge-failure prev-err kf)
  (lambda (err)
    (kf (merge-parse-errors err prev-err))))

(define (make-parse-error pos error-report)
  (cons pos (list error-report)))

;; Input streams need to supply
;;  - head item
;;  - parse position tip (not a position path!)
;;  - tail stream
;;
;; Only the parse position tip gets passed on EOF.

(define (input-stream-cons pos item tail)
  (lambda (ks kf)
    (ks pos item tail)))

(define (input-stream-position stream)
  (stream (lambda (pos item tail) pos)
	  (lambda (pos) pos)))

(define (input-stream-append s1 s2)
  (lambda (ks kf)
    (s1 (lambda (pos item tail)
	  (ks pos item (input-stream-append tail s2)))
	(lambda (pos)
	  (s2 ks kf)))))

(define input-stream-constructors '())

(define (->input-stream x)
  (let search ((ctors input-stream-constructors))
    (cond
     ((null? ctors) (error "Could not construct input stream" x))
     (((caar ctors) x) ((cdar ctors) x))
     (else (search (cdr ctors))))))

(define (input-stream->list input)
  (input (lambda (pos item tail) (cons item (input-stream->list tail)))
	 (lambda (pos) '())))

(define (register-input-stream-constructor! predicate ctor)
  (set! input-stream-constructors
	(cons (cons predicate ctor)
	      input-stream-constructors)))

(register-input-stream-constructor!
 procedure? ;; covering input streams themselves
 (lambda (s)
   s))

(register-input-stream-constructor!
 list?
 (lambda (l)
   (let loop ((position 0)
	      (l l))
     (if (null? l)
	 (lambda (ks kf) (kf position))
	 (lambda (ks kf)
	   (ks position (car l) (loop (+ position 1) (cdr l))))))))

(register-input-stream-constructor!
 string?
 (lambda (s)
   (let ((len (string-length s)))
     (let loop ((index 0)
		(position (top-file-parse-position "<string>")))
       (if (= index len)
	   (lambda (ks kf) (kf position))
	   (lambda (ks kf)
	     (let ((ch (string-ref s index)))
	       (ks position
		   ch
		   (loop (+ index 1)
			 (update-file-parse-position position ch))))))))))

(register-input-stream-constructor!
 vector?
 (lambda (v)
   (let ((len (vector-length v)))
     (let loop ((index 0))
       (if (= index len)
	   (lambda (ks kf) (kf index))
	   (lambda (ks kf) (ks position (vector-ref s index) (loop (+ index 1)))))))))

(register-input-stream-constructor!
 input-port?
 (lambda (p)
   (make-port-input-stream "<unknown>" p)))

(define (make-port-input-stream filename p)
  (let loop ((position (top-file-parse-position filename)))
    (let ((ch (read-char p)))
      (if (eof-object? ch)
	  (lambda (ks kf) (kf position))
	  (let ((next (delay (loop (update-file-parse-position position ch)))))
	    (lambda (ks kf) (ks position ch (force next))))))))

(define (current-input-stream)
  (make-port-input-stream "<stdin>" (current-input-port)))

;; The result of parsing is either (semantic-value * new-env * next * error) or (error)

;; (apply production-name arg ...) ; both name and arg may be variables; args implicit - pushed on the input stream!
;; (or parser ...)
;; (exactly datum) ; nil true false <number> 'string' #symbol $c "sequence of chars"
;; (sequence)
;; ; () for grouping
;; (nest parser) ; nested parse! (sequence)
;; (not parser)
;; (follow parser)
;; (many parser)
;; (many1 parser)
;; (bind name parser)
;; (seq parser ...)
;; (anything)
;; (action meta-exp); => exp, !exp, ?exp

(define (interpret-ometa start rules input ks kf)
  (define (eval-host exp env k)
    (cond
     ((symbol? exp)
      (cond
       ((assq exp env) => (lambda (entry) (k (cadr entry) (cddr entry))))
       (else (error "Unbound variable" exp))))
     ((pair? exp)
      (case (car exp)
	((quote) (k #f (cadr exp)))
	(else
	 (error "Applications not supported in eval-host" exp))))
     (else (k #f exp))))

  (define (push-actuals args env tail)
    (if (null? args)
	tail
	(eval-host (car args) env
		   (lambda (pos value)
		     (input-stream-cons pos value (push-actuals (cdr args) env tail))))))

  (define (collect-many exp env acc input err0 ks)
    (let collect ((acc acc)
		  (input input)
		  (prev-err err0))
      ;;(pretty-print `(collect-many ,(input-stream-position input) ,exp ,acc ,prev-err))
      (e exp env input
	 (lambda (sv new-env next err)
	   (collect (cons sv acc) next (merge-parse-errors err prev-err)))
	 (lambda (err)
	   ;;(pretty-print `(leaving ,exp ,acc ,prev-err and ,err))
	   (ks (reverse acc) env input (merge-parse-errors err prev-err))))))

  (define (nonshared-env env)
    (if (eq? env rules)
	'()
	(cons (car env) (nonshared-env (cdr env)))))

  (define (nonshared-env-values env)
    (if (eq? env rules)
	'()
	(cons (cddar env) (nonshared-env-values (cdr env)))))

  (define (shadowed-identifier s)
    (string->symbol (string-append "_" (symbol->string s))))

  (define (nonshared-env-names env)
    (let loop ((env env)
	       (acc '()))
      (cond
       ((eq? env rules) (reverse acc))
       ((memq (caar env) acc) (loop (cdr env) (cons (shadowed-identifier (caar env)) acc)))
       (else (loop (cdr env) (cons (caar env) acc))))))

  (define (compile-meta-exp exp names)
    (let ((success-sym (gensym)))
      (let ((source-form `(lambda (,success-sym error ,@names)
			    (,success-sym ,exp))))
	;;(pretty-print `((names ,names) (source-form ,source-form)))(newline)
	(eval source-form))))

  (define memo-tab (make-hash-table equal?))
  (define action-tab (make-hash-table equal?))

  (define (e exp env input ks kf)
    (if *ometa-debug*
	(pretty-print `(
			(exp ,exp)
			(env ,(nonshared-env env))
			(input ,(input-stream->list input))
			(pos ,(input-stream-position input))
			)))
    (case (car exp)
      ((apply)
       (let search-for-production ((production-exp (cadr exp)))
	 (eval-host production-exp env
	   (lambda (dummy-pos production)
	     (if (symbol? production)
		 (search-for-production production)
		 (let ((args (cddr exp)))
		   (if (null? args)
		       (let ((memo-probe (cons input production)))
			 (if (hash-table-exists? memo-tab memo-probe)
			     ((hash-table-ref memo-tab memo-probe)
			      (lambda (sv new-env next err) (ks sv env next err))
			      kf)
			     (e production rules input
				(lambda (sv new-env next err)
				  (hash-table-set! memo-tab memo-probe
						   (lambda (ks kf) (ks sv new-env next err)))
				  (ks sv env next err))
				(lambda (err)
				  (hash-table-set! memo-tab memo-probe
						   (lambda (ks kf) (kf err)))
				  (kf err)))))
		       (let ((extended-input (push-actuals args env input)))
			 (e production rules extended-input
			    (lambda (sv new-env next err)
			      (ks sv env next err))
			    kf)))))))))
      ((or)
       (if (null? (cdr exp))
	   (kf #f)
	   (let loop ((options (cdr exp))
		      (prev-err #f))
	     (cond
	      ((null? (cdr options))
	       (e (car options) env input
		  (merge-success prev-err ks)
		  (merge-failure prev-err kf)))
	      (else (e (car options) env input
		       (merge-success prev-err ks)
		       (lambda (err)
			 (loop (cdr options) (merge-parse-errors err prev-err)))))))))
      ((exactly)
       (let ((expected-value (cadr exp)))
	 (input (lambda (pos item tail)
		  (if (equal? item expected-value)
		      (ks item env tail #f)
		      (kf (make-parse-error pos `(expected ,expected-value)))))
		(lambda (pos)
		  (kf (make-parse-error pos `(expected ,expected-value)))))))
      ((sequence)
       (eval-host (cadr exp) env
	 (lambda (dummy-pos item0)
	   (let ((pos0 (input-stream-position input)))
	     (let loop ((xs (if (string? item0)
				(string->list item0)
				item0))
			(input input))
	       ;;(pretty-print `(in-sequence ,xs ,(list->string (input-stream->list input))))
	       (if (null? xs)
		   (ks item0 env input #f)
		   (input (lambda (pos item tail)
			    (if (equal? item (car xs))
				(loop (cdr xs) tail)
				(kf (make-parse-error pos0 `(expected ,item0)))))
			  (lambda (pos)
			    (kf (make-parse-error pos0 `(expected ,item0)))))))))))
      ((nest)
       (input (lambda (pos item tail)
		(e (cadr exp) env (->input-stream item)
		   (lambda (sv new-env next err)
		     (ks sv new-env tail err))
		   kf))
	      (lambda (pos)
		(kf (make-parse-error (input-stream-position input)
				      `(expected sequence-for-nesting))))))
      ((not)
       (e (cadr exp) env input
	  (lambda (sv new-env next err)
	    (kf (make-parse-error (input-stream-position input) `(failed-no-follow ,(cadr exp)))))
	  (lambda (err)
	    (ks #t env input #f))))
      ((follow)
       (e (cadr exp) env input
	  (lambda (sv new-env next err)
	    (ks sv new-env input err))
	  kf))
      ((many)
       (collect-many (cadr exp) env '() input #f ks))
      ((many1)
       (e (cadr exp) env input
	  (lambda (sv new-env next err)
	    (collect-many (cadr exp) env (list sv) next err ks))
	  kf))
      ((bind)
       (e (caddr exp) env input
	  (lambda (sv new-env next err)
	    (ks sv
		(cons (cons (cadr exp) (cons (input-stream-position input) sv)) new-env)
		next
		err))
	  kf))
      ((seq)
       (if (null? (cdr exp))
	   (ks #f env input #f)
	   (let loop ((exps (cdr exp))
		      (env env)
		      (input input)
		      (prev-err #f))
	     ;;(pretty-print `(in-seq (exps ,exps) (env ,(nonshared-env env))))
	     (if (null? (cdr exps))
		 (e (car exps) env input
		    (merge-success prev-err ks)
		    (merge-failure prev-err kf))
		 (e (car exps) env input
		    (lambda (sv new-env next err)
		      (loop (cdr exps) new-env next (merge-parse-errors err prev-err)))
		    (merge-failure prev-err kf))))))
      ((anything)
       (input (lambda (pos item tail) (ks item env tail #f))
	      (lambda (pos) (kf (make-parse-error pos 'end-of-stream)))))
      ((action)
       (let* ((names (nonshared-env-names env))
	      (probe (cons (cadr exp) names))
	      (fn (if (hash-table-exists? action-tab probe)
		      (hash-table-ref action-tab probe)
		      (let ((v (compile-meta-exp (cadr exp) names)))
			(hash-table-set! action-tab probe v)
			v)))
	      (escape '*)
	      (escaped (call-with-current-continuation
			(lambda (set-escaped!)
			  (set! escape (lambda error-report
					 (set-escaped! error-report)))
			  #f))))
	 (if escaped
	     (kf (make-parse-error (input-stream-position input) escaped))
	     (apply fn
		    (lambda (sv) (ks sv env input #f))
		    escape
		    (nonshared-env-values env)))))
      (else (error "Bad OMeta AST" exp))))

  (e `(apply ,start) rules input
     ks
     kf))

(define (grammar->env g)
  (map (lambda (raw-production)
	 (cons (car raw-production)
	       (cons #f ;; parse-position
		     (cadr raw-production))))
       g))

(define meta-ometa
  '(
    (productions (many1 (apply production)))

    (production (seq (bind n (follow (apply name)))
		     (bind x (apply production-part n))
		     (bind xs (many (seq (apply token ";")
					 (apply production-part n))))
		     (apply token ";")
		     (apply spaces)
		     (action `(,n (or ,x ,@xs)))))

    (production-part (seq (bind required-name (anything))
			  ;;
			  (bind n (apply name))
			  (action (or (eq? n required-name)
				      (error 'clause-name-mismatch)))
			  (bind body (apply expr-seq))
			  (or (seq (apply token "::=")
				   (bind rhs (apply expr))
				   (action `(seq ,body ,rhs)))
			      (action body))))

    (expr-seq (seq (bind xs (many (apply expr3)))
		   (action `(seq ,@xs))))

    (expr3 (or (seq (bind r (apply expr2))
		    (bind r (or (seq (apply token "*") (action `(many ,r)))
				(seq (apply token "+") (action `(many1 ,r)))
				(action r)))
		    (or (seq (exactly #\:) (bind n (apply name))
			     (action `(bind ,n ,r)))
			(action r)))
	       (seq (apply token ":") (bind n (apply name))
		    (action `(bind ,n (anything))))))

    (expr2 (or (seq (apply token "~") (bind x (apply expr2))
		    (action `(not ,x)))
	       (seq (apply token "&") (bind x (apply expr1))
		    (action `(follow ,x)))
	       (apply expr1)))

    (expr1 (or (seq (apply token "<{")
		    (bind s (apply host-language-expression))
		    (apply token "}>")
		    (action `(sequence ,s)))
	       (seq (apply token "<(")
		    (bind exps (apply scheme-sequence)) ;; production arg ...
		    (apply token ")>")
		    (action `(apply ,@exps)))
	       (seq (apply token "=>") (bind r (apply host-language-expression))
		    (action `(action ,r)))
	       (seq (apply token "?") (bind r (apply host-language-expression))
		    (action `(action (or ,r (error 'expected ',r)))))
	       (seq (bind x (apply literal))
		    (action `(exactly ,x)))
	       (seq (apply token "_") (action `(anything)))
	       (seq (apply token "(") (bind x (apply expr)) (apply token ")")
		    (action x))
	       (seq (apply token "{") (bind xs (apply expr-seq)) (apply token "}")
		    (action `(nest ,xs)))))

    (literal (or (apply okeyword "nil" ())
		 (apply okeyword "true" #t)
		 (apply okeyword "false" #f)
		 (apply onumber)
		 (apply ostring #\')
		 (seq (apply token "$") (apply ochar))
		 (seq (apply token "#") (or (apply name)
					    (seq (bind s (apply ostring #\'))
						 (action (string->symbol s)))))))

    (onumber (seq (apply spaces) (bind ip (many1 (apply digit)))
		  (or (seq (exactly #\.) (bind fp (many1 (apply digit)))
			   (action (string->number (string-append (list->string ip)
								  "."
								  (list->string fp)))))
		      (action (string->number (list->string ip))))))

    (ostring (seq (bind quo (apply ochar))
		  ;;
		  (apply spaces)
		  (bind s1 (apply ochar))
		  (action (or (eqv? s1 quo) (error 'expected 'string-open-quote)))
		  (bind cs (many (or (seq (exactly #\\)
					  (or (exactly #\\)
					      (seq (bind c (apply ochar))
						   (action (if (eqv? c quo)
							       c
							       (error 'expected
								      'escaped-quote))))))
				     (seq (bind c (apply ochar))
					  (action (if (eqv? c quo)
						      (error 'expected 'string-char)
						      c))))))
		  (bind s2 (apply ochar))
		  (action (if (eqv? s2 quo)
			      (list->string cs)
			      (error 'expected 'string-close-quote)))))

    (ochar (seq (bind c (anything))
		(action (if (char? c)
			    c
			    (error 'expected 'char?)))))

    (expr (seq (bind x (apply expr-seq))
	       (bind xs (many (seq (apply token "|") (apply expr-seq))))
	       (action `(or ,x ,@xs))))

    (okeyword (seq (bind xs (anything))
		   (bind val (anything))
		   ;;
		   (apply spaces) (sequence xs)
		   (not (apply name-subsequent '(#\- #\? #\! #\* #\+ #\/ #\= #\: #\')))
		   (action val)))

    (token (seq (bind xs (anything))
		;;
		(apply spaces) (sequence xs)))

    (name (apply generic-name
		 '()
		 '(#\- #\? #\! #\* #\+ #\/ #\= #\: #\')))

    (generic-name (seq (bind initial-chars (anything))
		       (bind subsequent-chars (anything))
		       ;;
		       (apply spaces)
		       (bind x (apply name-initial initial-chars))
		       (bind xs (many (apply name-subsequent subsequent-chars)))
		       (action (string->symbol (list->string (cons x xs))))))

    (name-initial (seq (bind initial-chars (anything))
		       ;;
		       (bind c (apply ochar))
		       (action (if (or (char-alphabetic? c)
				       (memv c initial-chars))
				   c
				   (error 'expected 'name-initial)))))

    (name-subsequent (seq (bind subsequent-chars (anything))
			  ;;
			  (bind x (apply ochar))
			  (action (if (or (char-alphabetic? x)
					  (char-numeric? x)
					  (memv x subsequent-chars))
				      x
				      (error 'expected 'name-subsequent)))))

    (digit (seq (bind c (apply ochar))
		(action (if (char-numeric? c)
			    c
			    (error 'expected 'char-numeric?)))))

    (spaces (or (seq (many1 (seq (bind c (apply ochar))
				 (action (if (char-whitespace? c)
					     c
					     (error 'expected 'char-whitespace?)))))
		     (apply spaces))
		(seq (exactly #\-) (exactly #\-)
		     (many (seq (bind x (anything))
				(action (if (memv x '(#\return #\newline))
					    (error 'expected 'non-eol)
					    x))))
		     (apply spaces))
		(action #t)))

    (host-language-expression (apply scheme-term))

    (scheme-term (or (apply scheme-atom)
		     (apply scheme-quoted "'" 'quote)
		     (apply scheme-quoted "`" 'quasiquote)
		     (apply scheme-quoted "," 'unquote)
		     (apply scheme-quoted ",@" 'unquote-splicing)
		     (seq (apply token "(")
			  (bind xs (apply scheme-sequence))
			  (apply token ")")
			  (action xs))))

    (scheme-quoted (seq (bind quo (anything))
			(bind sym (anything))
			;;
			(apply spaces)
			(sequence quo)
			(bind x (apply scheme-term))
			(action `(,sym ,x))))

    (scheme-atom (or (apply okeyword "#t" #t)
		     (apply okeyword "#f" #f)
		     (apply onumber)
		     (apply ostring #\")
		     (seq (apply token "#\\")
			  (or (seq (apply token "return") (action #\return))
			      (seq (apply token "newline") (action #\newline))
			      (apply ochar)))
		     (apply scheme-symbol)
		     (seq (bind s (apply ostring #\|))
			  (action (string->symbol s)))))

    (scheme-symbol (apply generic-name
			  '(#\? #\! #\* #\+ #\/ #\= #\: #\< #\>)
			  '(#\? #\! #\* #\+ #\/ #\= #\: #\< #\> #\' #\-)))

    (scheme-sequence (or (seq (bind a (apply scheme-term))
			      (apply token ".")
			      (bind d (apply scheme-term))
			      (action (cons a d)))
			 (seq (bind a (apply scheme-term))
			      (bind d (apply scheme-sequence))
			      (action (cons a d)))
			 (action '())))
    ))

(define (serialize-ometa-ast ast)
  (define (emit arg)
    (cond
     ((null? arg))
     ((pair? arg) (emit (car arg)) (emit (cdr arg)))
     (else (display arg))))
  (define (xi sep fn args)
    (if (null? args)
	'()
	(let loop ((args args))
	  (if (null? (cdr args))
	      (fn (car args))
	      (begin (list (fn (car args)) sep (loop (cdr args))))))))
  (define (xii op sep fn args cl)
    (list op (xi sep fn args) cl))
  (define (q qch str)
    (list qch (map (lambda (c) (if (eqv? c qch) (list #\\ qch) c)) (string->list str)) qch))
  (define (object->external-representation o)
    (let ((s (open-output-string)))
      (write o s)
      (get-output-string s)))
  (define (serialize-exp exp)
    (case (car exp)
      ((apply) (xii "<(" " " object->external-representation (cdr exp) ")>"))
      ((or) (xii "(" " | " serialize-exp (cdr exp) ")"))
      ((exactly) (let ((ev (cadr exp)))
		   (cond
		    ((null? ev) "nil")
		    ((eq? #t ev) "true")
		    ((eq? #f ev) "false")
		    ((number? ev) (number->string ev))
		    ((string? ev) (q #\' ev))
		    ((char? ev) (list "$" ev))
		    ((symbol? ev) (let ((s (symbol->string ev)))
				    (list "#" (if (memv #\' (string->list s))
						  (q #\' s)
						  s))))
		    (else (error "Invalid literal in serialize-exp exactly" ev)))))
      ((sequence) (list "<{"(object->external-representation (cadr exp))"}>"))
      ((nest) (list "{"(serialize-exp (cadr exp))"}"))
      ((not) (list "~"(serialize-exp (cadr exp))))
      ((follow) (list "&"(serialize-exp (cadr exp))))
      ((many) (list "("(serialize-exp (cadr exp))")*"))
      ((many1) (list "("(serialize-exp (cadr exp))")+"))
      ((bind) (if (equal? (caddr exp) '(anything))
		  (list ":"(cadr exp))
		  (list (serialize-exp (caddr exp))":"(cadr exp))))
      ((seq) (xi " " serialize-exp (cdr exp)))
      ((anything) "_")
      ((action) (list "=>"(object->external-representation (cadr exp))))
      (else (error "Bad AST in serialize" exp))))
  (define (serialize-production production)
    (list (car production)" ::=\n"
	  (serialize-exp (cadr production))
	  "\n;\n\n"))
  (emit (map serialize-production ast)))

(define (format-ometa-error err)
  (let ((s (open-output-string)))
    (display "Parse error at position " s)
    (write (car err) s)
    (newline s)
    (display "Error messages:" s)
    (newline s)
    (for-each (lambda (msg)
		(display " - " s)
		(write msg s)
		(newline s))
	      (cdr err))
    (get-output-string s)))

(define (report-ometa-error err)
  (display (format-ometa-error err))
  (newline)
  (error 'ometa-parse-error))

(define (parse-ometa input . maybe-error-handler)
  (let ((error-handler (if (null? maybe-error-handler)
			   report-ometa-error
			   (car maybe-error-handler))))
    (interpret-ometa 'productions (grammar->env meta-ometa) (->input-stream input)
		     (lambda (sv new-env tail err)
		       (if (null? (input-stream->list tail))
			   sv
			   (error-handler err)))
		     error-handler)))

(define (parse-ometa-file filename . maybe-error-handler)
  (call-with-input-file filename
    (lambda (port)
      (apply parse-ometa (make-port-input-stream filename port) maybe-error-handler))))

(define opt-ometa (parse-ometa-file (path->string (build-path (current-load-relative-directory)
							      "ometa-opt.g"))))
(define (opt g)
  (interpret-ometa 'opt-grammar (grammar->env opt-ometa) (->input-stream g)
		   (lambda (sv new-env tail err)
		     (pretty-print `(success (sv ,sv)
					     (pos ,(input-stream-position tail))
					     (tail ,(input-stream->list tail))
					     (err ,err)))
		     sv)
		   (lambda (err)
		     (pretty-print `(failure ,err))
		     err)))

(define (load-ometa filename . maybe-ometa-parser)
  (let ((grammar (opt ((if (null? maybe-ometa-parser)
			   parse-ometa-file
			   (car maybe-ometa-parser)) filename))))
    (lambda (start-symbol stream ks kf)
      (interpret-ometa start-symbol (grammar->env grammar) (->input-stream stream)
		       (lambda (sv new-env tail err)
			 (ks sv tail err))
		       (lambda (err)
			 ;;(pretty-print `(failure ,err))
			 (kf err))))))

(define (boot)
  (define (d x)
    (with-output-to-file x
      (lambda ()
	(display "-- -*- text -*-")
	(newline)
	(newline)
	(serialize-ometa-ast meta-ometa))))
  (d "m0.g")
  (set! meta-ometa (opt (parse-ometa-file "m0.g")))
  (d "m1.g")
  (set! meta-ometa (opt (parse-ometa-file "m1.g")))
  (d "m2.g")
  (set! meta-ometa (opt (parse-ometa-file "m2.g"))))

;;; Local Variables:
;;; eval: (put 'eval-host 'scheme-indent-function 2)
;;; End: