;; Written by Marc Nieper-Wißkirchen

;; TODO: make-variable-transformer and identifier-syntax.

;; TODO: make-synthetic-identifier should return a truly unique (that
;; is not free-identifier=? to any other) identifier.

;; TODO: Consecutive ellipses in syntax templates.

;; TODO: Write many more tests.

(define-syntax define-pattern-variable
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((id (cadr expr))
	   (binding (cddr expr)))
       (let ((mac (cdr (env-cell (current-usage-environment) id))))
	 (macro-aux-set! mac binding))
       `(,(rename 'begin))))))

(define (make-pattern-variable pvar)
  (lambda (expr)
    (error "reference to pattern variable outside syntax" pvar)))

(define (pattern-variable x)
  (let ((cell (env-cell (current-usage-environment) x)))
    (and cell (macro? (cdr cell)) (macro-aux (cdr cell)))))

(define (rename id)
  ((current-renamer) id))

(define (ellipsis? id)
  (free-identifier=? id (rename '...)))

(define bound-identifier=?
  (lambda (x y)
    (eq? x y)))

(define (syntax-transformer level)
  (er-macro-transformer
   (lambda (expr rename compare)
     (let*-values (((out envs)
		    (gen-template (cadr expr) '() ellipsis? level)))
       out))))

(define (syntax->datum stx)
  (strip-syntactic-closures stx))

(define-syntax syntax (syntax-transformer #f))
(define-syntax quasisyntax (syntax-transformer 0))
(define-auxiliary-syntax unsyntax)
(define-auxiliary-syntax unsyntax-splicing)

(define (gen-template tmpl envs ell? level)
  (cond
   ((pair? tmpl)
    (cond
     ((and (identifier? (car tmpl))
	   (free-identifier=? (car tmpl) (rename 'unsyntax)))
      (if (and level (zero? level))
	  (values (cadr tmpl) envs)
	  (let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (- level 1)))))
	    (values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs))))
     ((and (identifier? (car tmpl))
	   (free-identifier=? (car tmpl) (rename 'quasisyntax)))
      (let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (+ level 1)))))
	(values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs)))
     ((and (pair? (car tmpl))
	   (free-identifier=? (caar tmpl) (rename 'unsyntax)))
      (if (and level (zero? level))
	  (let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
	    (values `(,(rename 'cons*) ,@(cdar tmpl) ,out) envs))
	  (let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
			((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
	    (values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
		      ,out2) envs))))
     ((and (pair? (car tmpl))
	   (free-identifier=? (caar tmpl) (rename 'unsyntax-splicing)))
      (if (and level (zero? level))
	  (let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
	    (values `(,(rename 'append) ,@(cdar tmpl) ,out) envs))
	  (let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
			((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
	    (values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
		      ,out2) envs))))
     ((and (identifier? (car tmpl))
	   (ell? (car tmpl)))
      (gen-template (cadr tmpl) envs (lambda (id) #f) level))
     ((and (pair? (cdr tmpl))
	   (identifier? (cadr tmpl))
	   (ell? (cadr tmpl)))
      (let*-values (((out* envs)
		     (gen-template (cddr tmpl) envs ell? level))
		    ((out envs)
		     (gen-template (car tmpl) (cons '() envs) ell? level)))
	(if (null? (car envs))
	    (error "too many ellipses following syntax template" (car tmpl)))
	(values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx))
					 (,(rename 'cons) ,out ,(rename 'stx)))
		  ,out* ,@(car envs))
		(cdr envs))))
     (else
      (let*-values (((out1 envs)
		     (gen-template (car tmpl) envs ell? level))
		    ((out2 envs)
		     (gen-template (cdr tmpl) envs ell? level)))
	(values `(,(rename 'cons) ,out1 ,out2) envs)))))
   ((vector? tmpl)
    (let*-values (((out envs)
		   (gen-template (vector->list tmpl) envs ell? level)))
      (values `(,(rename 'list->vector) ,out) envs)))
   ((identifier? tmpl)
    (cond ((ell? tmpl)
	   (error "misplaced ellipsis in syntax template" tmpl))
	  ((pattern-variable tmpl) =>
	   (lambda (binding)
	     (values (car binding)
		     (update-envs tmpl (car binding) (cadr binding) envs))))
	  (else
	   (values (gen-data tmpl) envs))))
   (else
    (values `(,(rename 'quote) ,tmpl) envs))))

(define (gen-data id)
  `((,(rename 'current-renamer))
    (,(rename 'syntax-quote) ,id)))

(define (update-envs id x level envs)
  (let loop ((level level) (envs envs))
    (cond ((zero? level)
	   envs)
	  ((null? envs)
	   (error "too few ellipses following syntax template" id))
	  (else
	   (let ((outer-envs (loop (- level 1) (cdr envs))))
	     (cond ((member x (car envs) bound-identifier=?)
		    envs)
		   (else
		    (cons (cons x (car envs))
			  outer-envs))))))))

(define-syntax syntax-case
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((expr (cadr expr))
	   (lit* (car (cddr expr)))
	   (clause* (reverse (cdr (cddr expr))))
	   (error #'(error "syntax error" e)))
       #`(let ((e #,expr))
	   #,(if (null? clause*)
		 error
		 #`(let ((fail (lambda () #,error)))
		     #,(let loop ((clause (car clause*))
				  (clause* (cdr clause*)))
			 (if (null? clause*)
			     (gen-clause lit* clause)
			     #`(let ((fail (lambda ()
					     #,(gen-clause lit* clause))))
				 #,(loop (car clause*) (cdr clause*))))))))))))

(define (gen-clause lit* clause)
  (if (= 3 (length clause))
      (gen-output lit* (car clause) (cadr clause) (car (cddr clause)))
      (gen-output lit* (car clause) #t (cadr clause))))

(define (gen-output lit* pattern fender output-expr)
  (let*-values (((matcher vars)
		 (gen-matcher #'e lit* pattern '())))
    (matcher (lambda ()
	       #`(let-syntax #,(map (lambda (var)
				      #`(#,(car var)
					 (make-pattern-variable (syntax-quote #,(car var)))))
				    vars)
		   #,@(map (lambda (var)
			     #`(define-pattern-variable . #,var))
			   vars)
		   (if #,fender
		       #,output-expr
		       (fail)))))))

(define (gen-matcher e lit* pattern vars)
  (cond ((pair? pattern)
	 (cond
	  ((and (pair? (cdr pattern))
		(identifier? (cadr pattern))
		(ellipsis? (cadr pattern)))
	   (let* ((l (length+ (cddr pattern)))
		  (h (car (generate-temporaries '(#f))))
		  (t (car (generate-temporaries '(#f)))))
	     (let*-values (((head-matcher vars) (gen-map h lit* (car pattern) vars))
			   ((tail-matcher vars) (gen-matcher* t lit* (cddr pattern) vars)))
	       (values (lambda (k)
			 #`(let ((n (length+ #,e)))
			     (if (and n (>= n #,l))
				 (let*-values (((#,h #,t) (split-at #,e (- n #,l))))
				   #,(head-matcher (lambda ()
						     (tail-matcher k))))
				 (fail))))
		       vars))))
	  (else
	   (let ((e1 (car (generate-temporaries '(#f))))
		 (e2 (car (generate-temporaries '(#f)))))
	     (let*-values (((car-matcher vars)
			    (gen-matcher e1 lit* (car pattern) vars))
			   ((cdr-matcher vars)
			    (gen-matcher e2 lit* (cdr pattern) vars)))
	       (values (lambda (k)
			 #`(if (pair? #,e)
			       (let ((#,e1 (car #,e))
				     (#,e2 (cdr #,e)))
				 #,(car-matcher (lambda ()
						  (cdr-matcher k))))
			       (fail)))
		       vars))))))
        ((identifier? pattern)
	 (cond ((member pattern lit* free-identifier=?)
		(values (lambda (k)
			  #`(if (free-identifier=? #'#,pattern #,e)
				#,(k)
				(fail)))
			vars))
	       ((ellipsis? pattern)
		(error "misplaced ellipsis" pattern))
	       ((free-identifier=? pattern #'_)
		(values (lambda (k)
			  (k))
			vars))
	       (else
		(values (lambda (k)
			  (k))
			(alist-cons pattern (list e 0) vars)))))
	(else
	 (values (lambda (k)
		   #`(if (equal? (syntax->datum #,e) '#,pattern)
			 #,(k)
			 (fail)))
		 vars))))

(define (gen-map h lit* pattern vars)
  (let*-values (((matcher inner-vars) (gen-matcher #'g lit* pattern '())))
    (let ((loop (car (generate-temporaries '(#f))))
	  (g* (generate-temporaries inner-vars)))
      (values (lambda (k)
		#`(let #,loop ((#,h (reverse #,h))
			       #,@(map (lambda (g)
					 #`(#,g '()))
				       g*))
		       (if (null? #,h)
			   #,(k)
			   (let ((g (car #,h)))
			     #,(matcher (lambda ()
					  #`(#,loop (cdr #,h)
						    #,@(map (lambda (var g)
							      #`(cons #,(cadr var) #,g))
							    inner-vars g*))))))))
	      (fold (lambda (g var vars)
		      (alist-cons (car var) (list g (+ (cadr (cdr var)) 1)) vars))
		    vars g* inner-vars)))))

(define (gen-matcher* e lit* pattern* vars)
  (let loop ((e e) (pattern* pattern*) (vars vars))
    (cond ((null? pattern*)
	   (values (lambda (k)
		     #`(if (null? #,e)
			   #,(k)
			   (fail)))
		   vars))
	  ((pair? pattern*)
	   (let ((e1 (car (generate-temporaries '(#f))))
		 (e2 (car (generate-temporaries '(#f)))))
	     (let*-values (((car-matcher vars)
			    (gen-matcher e1 lit* (car pattern*) vars))
			   ((cdr-matcher vars)
			    (loop e2 (cdr pattern*) vars)))
	       (values (lambda (k)
			 #`(let ((#,e1 (car #,e))
				 (#,e2 (cdr #,e)))
			     #,(car-matcher (lambda ()
					      (cdr-matcher k)))))
		       vars))))
	  (else
	   (gen-matcher e lit* pattern* vars)))))

(define (make-synthetic-identifier id)
  (close-syntax id (environment)))

(define (generate-temporaries l)
  (map (lambda (x) (make-synthetic-identifier 't)) l))

(define-syntax with-syntax
  (lambda (x)
    (syntax-case x ()
      ((_ ((p e0) ...) e1 e2 ...)
       #'(syntax-case (list e0 ...) ()
	   ((p ...) (let () e1 e2 ...)))))))

(define (syntax-violation who message . form*)
  (apply error message form*))


;; TODO: Move datum->syntax from init-7 here.