[R6RS] Condition types as record types

[Michael Sperber]

This is taking up an old corner of the discussion on condition types.
Marc and Manuel asked that condition types be implemented as record
types of the same shapes, i.e. that the record type corresponding to a
condition type have the same fields, and that the inheritance
hierarchies correspond.

I've attached an implementation of SRFI 35 in terms of the current
version of SRFI 76.  As it stands, it's based on the procedural and
reflection layers.  The use of the reflection layer could be elided by
putting more stuff into the condition-type object.  (Note that the
definition of :CONDITION-TYPE could be elided---its only field
contains the record type.)  This is offered mostly as a
proof-of-concept, to show that it can be done quite straightforwardly
(I wrote it while waiting for a connecting flight at an airport),
rather than a production-quality implementation.

-- 
Cheers =8-} Mike
Friede, V?lkerverst?ndigung und ?berhaupt blabla

-------------- next part --------------
;; Condition types as in SRFI 35, implemented as record types as in SRFI 76

;; makes use of SRFIs 1 (lists), and 23 (error-reporting)

(define-type (:condition-type really-make-condition-type condition-type?) (rtd)
  (fields
   (rtd (condition-type-rtd) rtd)))

(define-type (:condition really-make-condition condition?) (reasons)
  (fields
   (reasons (condition-reasons) reasons)))

(define (make-condition-type id parent field-names)
  ;; #### should check for duplicate field names
  (really-make-condition-type
   (make-record-type-descriptor id
				(condition-type-rtd parent)
				#f
				#f
				#f
				(map (lambda (field-name)
				       (list 'immutable field-name))
				     field-names))))

(define (condition-type-all-fields condition-type)
  (rtd-all-fields (condition-type-rtd condition-type)))

(define (rtd-all-fields rtd)
  (if (not rtd)
      '()
      (append (rtd-all-fields (record-type-parent rtd))
	      (record-type-field-names rtd))))

(define (make-condition type . field-plist)
  (let ((alist (let label ((plist field-plist))
                 (if (null? plist)
		     '()
                     (cons (cons (car plist)
                                 (cadr plist))
                           (label (cddr plist)))))))
    (if (not (lset= eq?
                    (condition-type-all-fields type)
                    (map car alist)))
        (error "condition fields don't match condition type"
	       (condition-type-all-fields type)
	       (map car alist)))
    (really-make-condition
     (list
      (apply 
       (record-constructor (condition-type-rtd type))
       (map (lambda (field-name)
	      (cdr (assq field-name alist)))
	    (condition-type-all-fields type)))))))

(define (condition-has-type? condition condition-type)
  (let ((reason-has-type?
	 (record-predicate (condition-type-rtd condition-type)))) 
    
    (any
     (lambda (reason)
       (reason-has-type? reason))
     (condition-reasons condition))))

(define (record-ref record field-name succeed fail)
  (let loop ((rtd (record-type-descriptor record)))
    (cond
     ((not rtd)
      (fail))
     ((memq field-name (record-type-field-names rtd))
      (succeed ((record-accessor rtd field-name) record)))
     (else
      (loop (record-type-parent rtd))))))

(define (condition-ref condition field-name)
  (let loop ((reasons (condition-reasons condition)))
    (if (null? reasons)
	(error "condition-ref: field name doesn't occur in condition"
	       condition field-name)
	(record-ref (car reasons) field-name
		    values
		    (lambda ()
		      (loop (cdr reasons)))))))

(define (make-compound-condition . conditions)
  (really-make-condition
   (concatenate (map condition-reasons conditions))))

(define (extract-condition condition condition-type)
  (let loop ((reasons (condition-reasons condition)))
    (if (null? reasons)
	(error "extract-condition: condition didn't match type"
	       condition condition-type)
	(extract-condition-from-reason (car reasons)
				       condition-type
				       values
				       (lambda ()
					 (loop (cdr reasons)))))))

(define (extract-condition-from-reason reason condition-type
				       succeed fail)
  (let ((rtd (condition-type-rtd condition-type)))
    ;; could cache the predicate in the CONDITION-TYPE record
    (if ((record-predicate rtd)
	 reason)
	(succeed
	 (really-make-condition
	  (list
	   (apply
	    ;; could avoid this by stuffing more into condition-type
	    (record-constructor rtd)
	    (map
	     (lambda (field-name)
	       (record-ref reason field-name
			   values
			   (lambda ()
			     (error "this can't happen"))))
	     (condition-type-all-fields condition-type))))))
	(fail))))

(define-syntax define-condition-type
  (syntax-rules ()
    ((define-condition-type ?name ?supertype ?predicate
       (?field1 ?accessor1) ...)
     (begin
       (define ?name
         (make-condition-type '?name
                              ?supertype
                              '(?field1 ...)))
       (define (?predicate thing)
         (and (condition? thing)
              (condition-has-type? thing ?name)))
       (define (?accessor1 condition)
         (condition-ref (extract-condition condition ?name)
                        '?field1))
       ...))))

(define (rtd-extends? rtd-1 rtd-2)
  (let loop ((rtd-1 rtd-1))
    (cond
     ((not rtd-1) #f)
     ((eq? rtd-1 rtd-2) #t)
     (else
      (loop (record-type-parent rtd-1))))))

(define (common-supertype-rtd type-1 type-2)
  (let ((rtd-1 (condition-type-rtd type-1))
	(rtd-2 (condition-type-rtd type-2)))
    (let loop ((rtd-2 rtd-2))
      (cond
       ((not rtd-2) #f)
       ((rtd-extends? rtd-1 rtd-2) rtd-2)
       (else (loop (record-type-parent rtd-2)))))))

(define (complete-condition type field-alist
			    type-field-alist)
  (really-make-condition
   (list
    (apply
     (record-constructor (condition-type-rtd type))
     (map (lambda (field-name)
	    (cond
	     ((assq field-name field-alist) => cdr)
	     (else
	      (any (lambda (entry)
		     (cond
		      ((common-supertype-rtd (car entry) type)
		       => (lambda (supertype-rtd)
			    (cond
			     ((and
			       (memq field-name
				     (rtd-all-fields supertype-rtd))
			       (assq field-name (cdr entry)))
			      => cdr)
			     (else #f))))
		      (else #f)))
		   type-field-alist))))
	  (condition-type-all-fields type))))))

(define-syntax condition
  (syntax-rules ()
    ((condition (?type1 (?field1 ?value1) ...) ...)
     (condition*
      (list (cons ?type1 (list (cons '?field1 ?value1) ...)) ...)))))

(define (condition* type-field-alist)
  (apply
   make-compound-condition
   (map (lambda (entry)
	  (complete-condition (car entry) (cdr entry)
			      type-field-alist))
	type-field-alist)))

(define &condition
  (really-make-condition-type
   (make-record-type-descriptor '&condition
				#f
				#f
				#f
				#f
				'())))

(define-condition-type &message &condition
  message-condition?
  (message condition-message))

(define-condition-type &serious &condition
  serious-condition?)

(define-condition-type &error &serious
  error?)