(define-module (itla srfi-35)
  #:use-module (oop goops)
  #:use-module (oop goops util)
  #:use-module (srfi srfi-1)

  ;; (oop goops util) and (srfi srfi-1) both define any, every
  #:duplicates last
  
  #:export (make-condition-type
            condition-type? condition? condition-has-type?
            condition-ref
            make-condition make-compound-condition
            extract-condition
            &condition &message &error )
  #:export-syntax (define-condition-type condition))

(define-class <condition-meta> (<class>))
  
(define-class <condition> ()
  (%name #:accessor condition-type-name)
  #:metaclass <condition-meta>)

(define (condition-type? thing)
  (is-a? thing <condition-meta>))

(define (condition-type-all-fields type)
  (fold-right (lambda (slot lst)
                (let ((name (car slot)))
                  (if (eq? name '%name)
                      lst
                      (cons name lst))))
              '()
              (class-slots type)))

(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 "make-condition-type: duplicate field name" ))
  
  (make-class (list supertype) (map list fields) #:name name))

(define-macro (define-condition-type ?name ?supertype ?predicate . ?field-acc)
  `(begin
     (define ,?name
       (make-condition-type ',?name
                            ,?supertype
                            (map car ',?field-acc)))
     (define (,?predicate thing)
        (and (condition? thing)
             (condition-has-type? thing ,?name)))
     ,@(map
        (lambda (f-a)
          ;;(format #t "defining accesor: ~S\n" (cadr f-a))
          `(define (,(cadr f-a) condition)
             (condition-ref (extract-condition condition ,?name)
                            ',(car f-a))))
        ?field-acc)))

;; Stolen from oop/goops.scm
(define (list2set l)	       
  (let loop ((l l)
	     (res '()))
    (cond		       
     ((null? l) res)
     ((memq (car l) res) (loop (cdr l) res))
     (else (loop (cdr l) (cons (car l) res))))))

;; This should be in goops.scm, really
(define-public (class-supers c)
  (letrec ((allsubs (lambda (c)
		      (cons c (mapappend allsubs
					 (class-direct-supers c))))))
    (list2set (cdr (allsubs c)))))

(define (condition-subtype? subtype supertype)
  (or (equal? subtype supertype)
      (memq supertype (class-supers 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))))))

(define (condition? thing)
  (is-a? thing <condition>))

(define (make-condition type . field-plist)
  (let ((alist (let loop ((plist field-plist))
                 (if (null? plist)
                            '()
                     (cons (cons (car plist)
                                 (cadr plist))
                           (loop (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)))
    (let ((condition (make type)))
      (for-each (lambda (pr)
                  (slot-set! condition (car pr) (cdr pr)))
               alist)
      condition)))

(define (condition-has-type? condition type)
  (if
   (any (lambda (has-type)
          (condition-subtype? has-type type))
        (condition-types condition))
  #t #f))

(define condition-ref slot-ref)

(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-class <compound-condition> (<condition>)
  (%components #:init-keyword #:components))

(define (make-compound-condition condition-1 . conditions)
  (if (null? conditions)
      condition-1
      (make <compound-condition>
        #:components (cons condition-1 conditions))))

(define (extract-condition condition type)
    (if (not (condition-subtype? (class-of condition) type))
        (error "extract-condition: invalid condition type"
                      condition type))
    condition)

(define-macro (condition . forms)
  ;; forms: (type1 (field1 value1) ...) ...)
  `(make-compound-condition
    ,@(map
       (lambda (form)
         `(make-condition
           ,(car form)
           ,@(fold (lambda (entry lst)
                     (cons `(quote ,(car entry)) (cons (cadr entry) lst)))
                   '()
                   (cdr form))))
       forms)))

(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)
  (let ((own-class (class-of condition)))
    (cons own-class (class-direct-supers own-class))))

(define &condition <condition>)

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

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

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

;;; arch-tag: 1145fba2-0008-4c99-8304-a53cdcea50f9