;; Requires:
;;  - srfi-9 for define-record-type
;;  - srfi-13 for string-concatenate
;;  - defmacros
;;  - an error procedure taking n arguments
;;  - gensym taking 0 arguments

(define-record-type variant-type
  (make-variant-type name variant-names field-names field-predicates)
  variant-type?
  (name variant-type-name)
  (variant-names variant-type-variant-names)
  (field-names variant-type-field-names)
  (field-predicates variant-type-field-predicates))

(define-record-type variant-instance
  (make-variant-instance variant-type variant-name variant-index field-values)
  variant-instance?
  (variant-type variant-instance-variant-type)
  (variant-name variant-instance-variant-name)
  (variant-index variant-instance-variant-index)
  (field-values variant-instance-field-values))

(define-macro (define-datatype type-name pred-name . variant-defs)
  (let* ((variant-names (map car variant-defs))
	 (field-names (map (lambda (def)
			     (map (lambda (fielddef)
				    (if (pair? fielddef)
					(car fielddef)
					fielddef))
				  (cdr def)))
			   variant-defs))
	 (field-predicates (map (lambda (def)
				  (map (lambda (fielddef)
					 (and (pair? fielddef)
					      (cadr fielddef)))
				       (cdr def)))
				variant-defs))
	 (index-map (do ((i 0 (+ i 1))
			 (names variant-names (cdr names))
			 (acc '() (cons (cons (car names) i) acc)))
			((null? names) acc)))
	 (symapp (lambda syms
		   (string->symbol (string-concatenate (map symbol->string syms))))))
    `(begin (define ,type-name
	      (make-variant-type ',type-name
				 '#(,@variant-names)
				 '#(,@field-names)
				 '#(,@field-predicates)))
	    (define ,pred-name
	      (lambda (x)
		(and (variant-instance? x)
		     (eq? (variant-instance-variant-type x) ,type-name))))
	    ,@(map (lambda (variant-name variant-field-names variant-field-preds)
		     (let ((pred-cache (map (lambda (variant-field-pred)
					      (list (gensym) variant-field-pred))
					    variant-field-preds)))
		       `(define ,(symapp 'make- variant-name)
			  (let ,pred-cache
			    (lambda ,variant-field-names
			      (if (and ,@(map (lambda (variant-field-name pred-cache-entry)
						(if (cadr pred-cache-entry)
						    `(,(car pred-cache-entry) ,variant-field-name)
						    '#t))
					      variant-field-names
					      pred-cache))
				  (make-variant-instance ,type-name
							 ',variant-name
							 ,(cdr (assq variant-name index-map))
							 (vector ,@variant-field-names))
				  (error "Argument type error"
					 ',(symapp 'make- variant-name)
					 (list ,@variant-field-names))))))))
		   variant-names
		   field-names
		   field-predicates))))

(define-macro (cases variant-type item . clauses)
  (let ((vtype (gensym))
	(vitem (gensym))
	(vvals (gensym)))
    `(let ((,vtype ,variant-type)
	   (,vitem ,item))
       (if (and (variant-instance? ,vitem)
		(eq? (variant-instance-variant-type ,vitem) ,vtype))
	   (let ((,vvals (variant-instance-field-values ,vitem)))
	     (case (variant-instance-variant-name ,vitem)
	       ,@(map (lambda (clause)
			(if (eq? (car clause) 'else)
			    clause
			    (let ((variant-name (car clause))
				  (variant-fields (cadr clause))
				  (body (cddr clause)))
			      (if (eq? variant-fields '_)
				  `((,variant-name)
				    ,@body)
				  `((,variant-name)
				    (let ,(do ((i 0 (+ i 1))
					       (fields variant-fields (cdr fields))
					       (acc '() (cons `(,(car fields)
								(vector-ref ,vvals ,i))
							      acc)))
					      ((null? fields) acc))
				      ,@body))))))
		      clauses)
	       ,@(if (assq 'else clauses)
		     '()
		     `((else (error "Nonexhaustive match failure"
				    ,vitem
				    ,vtype))))))
	   (error "Item is not of correct datatype"
		  ,vitem
		  ,vtype)))))

(define (variant-case-predicate variant-type variant-name)
  (lambda (x)
    (and (variant-instance? x)
	 (eq? (variant-instance-variant-type x) variant-type)
	 (eq? (variant-instance-variant-name x) variant-name))))

;; Helper predicates for use in type-test positions in define-datatype
;; variant definitions.

(define (list-of-type predicate)
  (lambda (x) (every predicate x)))

(define (alist-of key-pred value-pred)
  (lambda (x) (every (lambda (cell) (and (key-pred (car cell))
					 (value-pred (cdr cell))))
		     x)))