#!/bin/sh

string=? ; exec /home/mflatt/plt/bin/mzscheme -r $0 "$@"

;; Class with overloaded init => single init w/max args
;; Class with overloaded method => single method w/union
;; Multiple top-level function specs => single spec w/union

(require-library "pretty.ss")
(require-library "functio.ss")

(define globals (make-hash-table))
(define classes (make-hash-table))

(define-struct cl (super def))

(define (do-class cldef)
  (let ([name (cadr cldef)]
	[super (cadr (caddr cldef))]
	[rest (cddr (caddr cldef))])
    (let loop ([inits (list (car rest))][rest (cdr rest)][multi? #f])
      (if (and (pair? (car rest))
	       (eq? (caar rest) 'public))
	  (let ([publics (cdar rest)]
		[init (if multi?
			  (resolve-multi-inits inits)
			  (car inits))])
	    (hash-table-put! classes name
			     (make-cl
			      super
			      `(class ,super ,init
				       (public ,@(do-publics publics))))))
	  (loop (append inits (list (car rest))) (cdr rest) #t)))))

(define (resolve-multi-inits i)
  (if (andmap null? i)
      null
      (cons
       (let loop ([t #f][i i])
	 (cond
	  [(null? i) t]
	  [(null? (car i)) (loop t (cdr i))]
	  [else 
	   (let ([v (caar i)])
	     (loop
	      (cond
	       [(symbol? v) 
		(cond
		 [(not t) v]
		 [(symbol? t) (string->symbol
			       (string-append
				(symbol->string t)
				"-or-"
				(symbol->string v)))]
		 [else t])]
	       [(pair? t) 
		(if (equal? t v)
		    t
		    `(,(car v) (type: (union ,(cadadr v) ,(cadadr t)))))]
	       [else v])
	      (cdr i)))]))
       (resolve-multi-inits 
	(map (lambda (x)
	       (if (null? x)
		   null
		   (cdr x)))
	     i)))))

(define (do-publics p)
  (let ([ht (make-hash-table)])
    (for-each
     (lambda (pub)
       (hash-table-put-union! ht (car pub) (cadr pub)))
     p)
    (hash-table-map ht list)))

(define (hash-table-put-union! ht k v)
  (let* ([old-v (hash-table-get ht k (lambda () #f))])
    (hash-table-put! ht k 
		     (if old-v
			 `(type: (union ,(cadr v) ,(cadr old-v)))
			 v))))

(let loop ()
  (let ([v (read)])
    (unless (eof-object? v)
	    (let ([spec-kind (caaddr v)])
	      (if (eq? spec-kind 'class)
		  (do-class v)
		  (let* ([name (cadr v)]
			 [type (cadr (caddr v))])
		    (hash-table-put-union! globals name type))))
	    (loop))))

(hash-table-for-each
 globals
 (lambda (k v)
   (pretty-print `(define ,k (type: ,v)))))

(map
 (lambda (i)
   (let ([name (car i)]
	 [cl (cdr i)])
     (newline)
     (pretty-print `(define ,name ,(cl-def cl)))))
 ; Sort classes so that superclasses are first
 (quicksort (hash-table-map classes cons)
	    (lambda (a b)
	      (let ([a-name (car a)])
		(let loop ([cl (cdr b)])
		  (let ([super (cl-super cl)])
		    (cond
		     [(eq? a-name super) #t]
		     [(eq? 'null super) #f]
		     [else
		      (let ([s (hash-table-get classes super
					       (lambda () #f))])
			(if s
			    (loop s)
			    #f))])))))))


			
