;;; A define-datatype and type-case macro package for DrScheme
;;; by Jonathan Sobel (with input from erik hilsdale)

;;; This system uses the DrScheme's class/object mechanism.
;;; The type-case form uses the visitor pattern.

(define-macro define-datatype
  (letrec
      ((valid-field?
	(lambda (x)
	  (or (#%symbol? x)
	      (and (#%list? x)
		   (#%= (#%length x) 2)
		   (#%symbol? (#%car x))))))
       (valid-fields?
	(lambda (fields)
	  (#%andmap valid-field? fields)))
       (as-string
	(lambda (x)
	  (cond
	   ((#%string? x) x)
	   ((#%symbol? x) (#%symbol->string x))
	   ((#%character? x) (#%string x))
	   (else (#%error 'define-datatype
			"cannot create identifier from ~s"
			x)))))
       (build-id
	(lambda parts
	  (#%string->symbol (#%apply string-append (#%map as-string parts)))))
       (make-class-name
	(lambda (sym)
	  (build-id "<" sym ">")))
       (make-visitor-names
	(lambda (sym)
	  (build-id "for-" sym)))
       (make-constructor-name
	(lambda (sym)
	  (build-id "make-" sym)))
       (make-predicate-name
	(lambda (sym)
	  (build-id sym "?"))))

    (lambda (type-name . variants)
      (cond
       ((#%not (#%andmap #%list? variants))
	(#%error 'define-datatype "malformed variants"))
       (else
	(let ((variant-names (#%map #%car variants))
	      (field-descriptors (#%map #%cdr variants)))
	  (cond
	   ((#%not (#%andmap #%symbol? variant-names))
	    (#%error 'define-datatype "variant names must be identifiers"))
	   ((#%not (#%andmap valid-fields? field-descriptors))
	    (#%error 'define-datatype "malformed field descriptions"))
	   (else
	    (let ((parent-class-name (make-class-name type-name))
		  (variant-class-names (#%map make-class-name
					    variant-names))
		  (visitor-names (#%map make-visitor-names
				      variant-names))
		  (constructor-names (#%map make-constructor-name
					  variant-names))
		  (predicate-name (make-predicate-name type-name)))
	      `(begin
		 (define ,parent-class-name
		   (class null ()
		     (public
		       (accept (lambda (ask)
				 (#%error ',parent-class-name
					"internal: unexpected except"))))))
		 (define ,predicate-name
		   (lambda (x) (#%is-a? x ,parent-class-name)))
		 ,@(#%map (lambda (variant-class-name
				 constructor-name
				 visitor-name
				 fields)
			  (let ((field-names
				 (#%map (lambda (x)
					(cond
					 ((#%symbol? x) x)
					 (else (#%car x))))
				      fields))
				(preds
				 (#%map (lambda (x)
					(cond
					 ((#%symbol? x)
					  `(lambda (x) #t))
					 (else (#%cadr x))))
				      fields))
				(params
				 (#%map (lambda (x)
					(#%gensym))
				      fields)))
			    `(begin
			       (define ,variant-class-name
			         (class ,parent-class-name ,params
				   (public
				     ,@(#%map (lambda (field param)
					      `(,field ,param))
					    field-names
					    params)
				     (accept (lambda (ask)
					       (#%send ask
						     ,visitor-name
						     ,@field-names)))
				     (sequence
				       (super-init)))))
			       (define ,constructor-name
				   (lambda ,field-names
				     (if (and ,@(#%map (lambda (pred field)
						       `(,pred ,field))
						     preds
						     field-names))
					 (#%make-object ,variant-class-name
						      ,@field-names)
					 (#%error ',constructor-name
						"invalid argument types")))))))
			  variant-class-names
			  constructor-names
			  visitor-names
			  field-descriptors)
		 (define ,type-name
		   (letrec (
       ;; ARGS:
       ;; table is an a-list like this:  ((empty-list 0) (pair 2))
       ;; name is a symbol like this: pair
       ;; clauses are the type-case clauses
       ;; RETURNS:
       ;; list of formals to be bound for rhs of clause that matches name
       ;; list of bodies from rhs of clauses that matches name
       (variant-assoc
	(letrec ((gen-temps
		  (lambda (n)
		    (cond
		     ((#%zero? n) '())
		     (else (#%cons (#%gensym) (gen-temps (#%- n 1))))))))
	  (lambda (table name clauses)
	    (cond
	     ((#%null? clauses)
	      (#%error 'type-case "no clause for ~a" name))
	     ((and (#%null? (#%cdr clauses)) (#%eqv? (#%car (#%car clauses)) 'else))
	      (let ((entry (#%assv name table)))
		(if entry
		    (#%values (gen-temps (#%cadr entry)) (#%cdr (#%car clauses)))
		    (#%error 'type-case
			   "~a is not a variant of the type"
			   name))))
	     ((#%eqv? (#%car (#%car clauses)) 'else)
	      (#%error 'type-case "else clause must be last"))
	     ((#%eqv? (#%car (#%car (#%car clauses))) name)
	      (let ((entry (#%assv name table)))
		(if entry
		    (let ((formals (#%cdr (#%car (#%car clauses)))))
		      (if (#%eqv? (#%length formals) (#%cadr entry))
			  (#%values formals (#%cdr (#%car clauses)))
			  (#%error 'type-case
				 "incorrect number of parameters in ~a variant"
				 name)))
		    (#%error 'type-case "~a is not a variant of the type"))))
	     (else
	      (variant-assoc table name (#%cdr clauses)))))))
       )
		     (let ((variant-table
			    (#%list ,@(#%map (lambda (variant-name fields)
					   `(#%list ',variant-name
						  ,(length fields)))
					 variant-names
					 field-descriptors))))
		     (lambda (expr clauses)
		       `(#%send ,expr accept
			      (#%make-object
			       (class null ()
				 (public
				   ,@(#%map (lambda (visitor-name
						   variant-name)
					    (#%call-with-values
					     (lambda ()
					       (variant-assoc variant-table
							      variant-name
							      clauses))
					     (lambda (formals body)
					       `(,visitor-name
						 (lambda ,formals
						   ,@body)))))
					  ',visitor-names
					  ',variant-names)))))))))))))))))))

(define-macro type-case
  (lambda (type expr . clauses)
    (let ((handler (#%eval type)))
      (if (#%procedure? handler)
	  (handler expr clauses)
	  (#%error 'type-case "~s is not a datatype" type)))))