;;;; fast-generic-compile-time.scm


(module fast-generic-compile-time (generic-build-name
				   generic-data-add
				   build-or-clause
				   generic-forms
				   is-a
				   register-type
				   type-heritage)

(import scheme chicken)
(use data-structures srfi-1 matchable)


(define (is-a? derived base)
  (if (eq? derived base)
      #t
      (let ((d (get derived 'is-a)))
	(if (and d (memq base (cdr d)))
	    #t
	    #f))))

(define (is-a derived base)
  (if (is-a? base derived)
      (error 'is-a
	     (sprintf "declaring a ~a to be a ~a creates circularity"
		      derived
		      base))
      (let ((d (get derived 'is-a)))
	(if d
	    (if (and (not (null? (cdr d)))
		     (not (eq? (cadr d) base)))
		(warning 
		 (sprintf "~a is-a ~a replaces ~a is-a ~a"
			  derived base derived (cadr d))))
	    (begin
	      (set! d (cons derived '()))
	      (put! derived 'is-a d)))
	(let ((b (get base 'is-a)))
	  (if (not b)
	      (begin
		(set! b (cons base '()))
		(put! base 'is-a b)))
	  (set-cdr! d b)))))

(define (generic-forms name)
  (let ((tree (get name 'generic-trees))
	(forms '()))
    (let tree-loop ((tree tree)
		    (args '()))
      (if (car tree)
	  (set! forms (cons (cons (car tree) (reverse args)) forms)))
      (if (not (null? (cdr tree)))
	  (let type-loop ((types (cdr tree)))
	    (if (not (null? types))
		(begin
		  (tree-loop (cdar types) (cons (caar types) args))
		  (type-loop (cdr types)))))))
    forms))

(define (generic-method-at-depth? d tree)
  (if (positive? d)
      (if (or (null? tree)
	      (null? (cdr tree)))
	  #f
	  (any (lambda (x)
		 (generic-method-at-depth? (- d 1) (cdr x)))
	       (cdr tree)))
      (car tree)))

(define (generic-build-name name predicates)
  (letrec ((build-predlist
	    (lambda (preds)
	      (if (null? preds)
		  ""
		  (string-append "-"
				 (symbol->string (car preds))
				 (build-predlist (cdr preds)))))))
    (string->symbol
     (string-append (symbol->string name)
		    "<"
		    (if (null? predicates)
			""
			(string-append (symbol->string (car predicates))
				       (build-predlist (cdr predicates))))
		    ">"))))

(define (generic-tree-depth tree)
  (if (or (null? tree)
	  (null? (cdr tree)))
      0
      (+ 1
	 (apply max (map (lambda (x)
			   (generic-tree-depth (cdr x)))
			 (cdr tree))))))

(define (build-next-arg-clause tree arg-names r)
  (if (null? tree)
      '#f
      (let* ((arg (gensym))
	     (arg-names (cons arg arg-names)))
	`(,(r 'let) ((,arg (,(r 'car) args))
		     (args (,(r 'cdr) args)))
	  (,(r 'or) ,@(map (lambda (t)
			     (build-pred-clause t arg-names r)) 
			   tree))))))

(define (type->predicate t)
  (let ((types (get (strip-syntax t) 'generic-types)))
    (if (symbol? types)
	types				; for builtin `any' type
	(let* ((cm (##sys#current-module))
	       (a (assq cm types)))
	  (if a
	      (cdr a)
	      (error 'define-generic "undefined type" t))))))

(define (type->test t arg r)
  (if (eq? t 'any)
      `(##core#let ((,(gensym) ,arg))
		   #t)
      (let ((p (type->predicate t)))
	(list (r p) arg))))

(define (build-pred-clause tree arg-names r)
  (if (null? tree)
      `#f
      `(,(r 'and) ,(type->test (car tree) (car arg-names) r)
	,(build-match-clause (cdr tree) arg-names r))))

(define (build-match-clause tree arg-names r)
  `(,(r 'if) (,(r 'null?) args)
    ,(if (car tree)
	 `(,(r 'begin)
	   (,(r 'set!) result (,(car tree) ,@(reverse arg-names)))
	   #t)
	 #f)
    ,(if (null? (cdr tree))
	 #f
	 (build-next-arg-clause (cdr tree) arg-names r))))

(define (generic-tree-insert tree full-name preds)
  (if (null? tree)
      (set! tree (cons #f '())))
  (if (null? preds)
      (begin
	(if (car tree)
	    (warning "redefining generic" full-name))
	(set-car! tree full-name))
      (let* ((choices (cdr tree))
	     (rest (assq (car preds) choices)))
	(if rest
	    (set-cdr! rest (generic-tree-insert (cdr rest)
						full-name
						(cdr preds)))
	    (set-cdr! tree
		      (sort
		       (cons (cons (car preds)
				   (generic-tree-insert
				    '() full-name (cdr preds)))
			     choices)
		       (lambda (a b) (is-a? (car a) (car b)))
		       )))))
  tree)

(define (generic-data-add name full-name preds)
  (let ((tree (get name 'generic-trees)))
    (if (not tree)
	(set! tree '()))
    (set! tree (generic-tree-insert tree full-name preds))
    (put! name 'generic-trees tree)))

(define (build-or-clause tree args full-args return-arg r)
  (if (null? args)
      `(,(r 'begin) (,(r 'set!) ,return-arg (,(car tree) ,@full-args))
	#t)
      (let ((and-clause (build-and-clause (cdr tree)
					  args
					  full-args
					  return-arg
					  r)))
	(if (null? and-clause)
	    #f
	    `(,(r 'or) ,@and-clause)))))

(define (build-and-clause clauses args full-args return-arg r)
  (if (null? clauses)
      '()
      (let ((clause (car clauses))
	    (l (length args))
	    (rest (build-and-clause (cdr clauses)
				    args
				    full-args
				    return-arg
				    r)))
	(let ((or-clause (build-or-clause (cdr clause)
					  (cdr args)
					  full-args
					  return-arg
					  r)))
	  (if (generic-method-at-depth? (- l 1) (cdr clause))
;; 	      (if ((eval (car clause)) (car raw-args))
;; 		  (cons or-clause rest)
;; 		  (if (and (symbol? (car raw-args))
;; 			   or-clause)
;; 		      (cons `(,(r 'and) (,(car clause) ,(car args))
;; 			      ,or-clause)
;; 			    rest)
;; 		      rest))
	      (cons `(,(r 'and) ,(type->test (car clause) (car args) r)
		      ,or-clause)
		    rest)
	      rest)))))

(define (type-heritage type)
  (let ((t (get type 'is-a)))
    (if (not t)
	(begin
	  (set! t (cons type '()))
	  (put! type 'is-a t)))
    t))

(define (register-type b p d)
  (define (defderived b p d)
    (is-a b (base d))
    (put! b 'generic-types
	  (cons (cons (##sys#current-module) p)
		(get b 'generic-types))))
  (define (base def)
    (match def
      ((? symbol?) def)
      ((b p) (base `(,b ,p any)))
      (((? symbol? d) p b2)
       (defderived d p b2)
       d)))
  (defderived b p d))


(put! 'any 'generic-type '##fast-generic#any?)

)