(require-library srfi-1)

(module

 ;; SRFI 35 reference implementation, dancing around a name clash with
 ;; chicken3.  TODO remove the dance, that's what the module system is
 ;; supposed be to good for.  Also clean up the export list!

 srfi-35 *

 (import scheme
	 (except chicken condition?)
	 (rename chicken (condition? orig.condition?))
	 srfi-1)

 (define-record-type :condition-type
   (really-make-condition-type name supertype fields all-fields)
   condition-type?
   (name condition-type-name)
   (supertype condition-type-supertype)
   (fields condition-type-fields)
   (all-fields condition-type-all-fields))

 (define (make-condition-type name supertype fields)
   (if (not (symbol? name))
       (error "make-condition-type: name is not a symbol"
	      name))
   (if (not (condition-type? supertype))
       (error "make-condition-type: supertype is not a condition type"
	      supertype))
   (if (not
	(null? (lset-intersection eq?
				  (condition-type-all-fields supertype)
				  fields)))
       (error "duplicate field name" ))
   (really-make-condition-type name
			       supertype
			       fields
			       (append (condition-type-all-fields supertype)
				       fields)))

 (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 (condition-subtype? subtype supertype)
   (let recur ((subtype subtype))
     (cond ((not subtype) #f)
	   ((eq? subtype supertype) #t)
	   (else
	    (recur (condition-type-supertype subtype))))))

 (define (condition-type-field-supertype condition-type field)
   (let loop ((condition-type condition-type))
     (cond ((not condition-type) #f)
	   ((memq field (condition-type-fields condition-type))
	    condition-type)
	   (else
	    (loop (condition-type-supertype condition-type))))))

 ;; The type-field-alist is of the form
 ;; ((<type> (<field-name> . <value>) ...) ...)
 (define-record-type :condition
   (really-make-condition type-field-alist)
   condition?*
   (type-field-alist condition-type-field-alist))

 (define chicken-condition? orig.condition?)

 (define (condition? obj)
   (or (condition?* obj) (chicken-condition? obj)))

 (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"))
     (really-make-condition (list (cons type alist)))))

 (define (condition-has-type? condition type)
   (and (condition?* condition)
	(any (lambda (has-type)
	       (condition-subtype? has-type type))
	     (condition-types condition))))

 (define (condition-ref condition field)
   (type-field-alist-ref (condition-type-field-alist condition)
			 field))

 (define (type-field-alist-ref type-field-alist field)
   (let loop ((type-field-alist type-field-alist))
     (cond ((null? type-field-alist)
	    (error "type-field-alist-ref: field not found"
		   type-field-alist field))
	   ((assq field (cdr (car type-field-alist)))
	    => cdr)
	   (else
	    (loop (cdr type-field-alist))))))

 (define (make-compound-condition condition-1 . conditions)
   (really-make-condition
    (apply append (map condition-type-field-alist
		       (cons condition-1 conditions)))))

 (define (extract-condition condition type)
   (let ((entry (find (lambda (entry)
			(condition-subtype? (car entry) type))
		      (condition-type-field-alist condition))))
     (if (not entry)
	 (error "extract-condition: invalid condition type"
		condition type))
     (really-make-condition
      (list (cons type
                  (map (lambda (field)
                         (assq field (cdr entry)))
                       (condition-type-all-fields type)))))))

 (define-syntax condition
   (syntax-rules ()
     ((condition (?type1 (?field1 ?value1) ...) ...)
      (type-field-alist->condition
       (list
	(cons ?type1
	      (list (cons '?field1 ?value1) ...))
	...)))))


 (define (type-field-alist->condition type-field-alist)
   (really-make-condition
    (map (lambda (entry)
	   (cons (car entry)
		 (map (lambda (field)
			(or (assq field (cdr entry))
			    (cons field
				  (type-field-alist-ref type-field-alist field))))
		      (condition-type-all-fields (car entry)))))
	 type-field-alist)))

 (define (condition-types condition)
   (if (condition?* condition)
       (map car (condition-type-field-alist condition))
       '()))

 (define (check-condition-type-field-alist the-type-field-alist)
   (let loop ((type-field-alist the-type-field-alist))
     (if (not (null? type-field-alist))
	 (let* ((entry (car type-field-alist))
		(type (car entry))
		(field-alist (cdr entry))
		(fields (map car field-alist))
		(all-fields (condition-type-all-fields type)))
	   (for-each (lambda (missing-field)
		       (let ((supertype
			      (condition-type-field-supertype type missing-field)))
			 (if (not
			      (any (lambda (entry)
				     (let ((type (car entry)))
				       (condition-subtype? type supertype)))
				   the-type-field-alist))
			     (error "missing field in condition construction"
				    type
				    missing-field))))
		     (lset-difference eq? all-fields fields))
	   (loop (cdr type-field-alist))))))

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

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

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

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

 )

(import (prefix srfi-35 srfi-35:))
(print srfi-35:condition?)