GOOPS-based SRFI-35 implementation

[Andreas Rottmann <a.rottmann@gmx.at>]

[-- Attachment #1: Type: text/plain, Size: 1224 bytes --]

Hi!

I just wanted to announce that I've been working a bit on a
GOOPS-based implementation of SRFI-35 ("Conditions"). It seems to
basically work, except compound conditions, which are not-yet
implemented. My implementation is based on the SRFI reference
implementation, but differs a good deal because it uses GOOPS classes
instead of SRFI-9 ("Defining record types"). 

Right now, the thing lives in the module (itla srfi-35), since my iTLA
thingy[0] will use it. I'd like comments:

[0] http://yi.org/rotty/ITLA

* On issues with the code

* How to proceed to get this into Guile

* How I can ship it with iTLA in a way that's compatible with both
  Guile versions that don't come with this SRFI and Guile CVS (which
  might come with it in the near future /mehopes). I thought
  installing it into /usr/[local/]guile/srfi/srfi-35.scm might work,
  since this will be used if there is no such module in
  /usr/[local/]guile/1.X/srfi and the one in Guile will be prefered if
  present.

* Everything else that matters (or doesn't ;-)

The latest & greatest code is always available via Arch (see [0]),
though I've attached the code and test cases (basically the examples
in the SRFI; non-working stuff is commented out).


[-- Attachment #2: srfi-35.scm --]
[-- Type: text/plain, Size: 6162 bytes --]

(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

[-- Attachment #3: srfi-35.test --]
[-- Type: text/plain, Size: 1926 bytes --]

#!/bin/sh
exec ${srcdir:-.}/guile-test-env guile -s "$0" "$@"
!#

(define-module (test-suite test-srfi-35)
  #:use-module (itla srfi-35)
  #:use-module (test-suite lib))

(define-condition-type &c &condition
  c?
  (x c-x))

(define-condition-type &c1 &c
  c1?
  (a c1-a))

(define-condition-type &c2 &c
  c2?
  (b c2-b))

(define v1 (make-condition &c1 'x "V1" 'a "a1"))
(define v2 (condition (&c2 (x "V2") (b "b2"))))
; (define v3 (condition (&c1 (x "V3/1") (a "a3"))
;                       (&c2 (b "b3"))))


(with-test-prefix "condition of type &c1"
  (pass-if "supertype predicate" (c? v1))
  (pass-if "predicate" (c1? v1))
  (pass-if "sibling predicate" (not (c2? v1)))
  (pass-if "parent field accessor" (string=? (c-x v1) "V1"))
  (pass-if "field accessor" (string=? (c1-a v1) "a1")))
  

(with-test-prefix "condition of type &c2"
  (pass-if "supertype predicate" (c? v2))
  (pass-if "predicate" (c2? v2))
  (pass-if "sibling predicate" (not (c1? v2)))
  (pass-if "parent field accessor" (string=? (c-x v2) "V2"))
  (pass-if "field accessor" (string=? (c2-b v2) "b2")))

; (with-test-prefix "condition of compound type (&c1 &c2)"
;   (pass-if "supertype predicate" (c? v2))
;   (pass-if "c1 predicate" (c1? v2))
;   (pass-if "c2 predicate" (c2? v2))
;   (pass-if "parent field accessor" (string=? (c-x v2) "V3/1"))
;   (pass-if "c1 field accessor" (string=? (c1-a v2) "a3"))
;   (pass-if "c2 field accessor" (string=? (c2-b v2) "b3")))

; (define v4 (make-compound-condition v1 v2))

; (c? v4)        => #t
; (c1? v4)       => #t
; (c2? v4)       => #t
; (c-x v4)       => "V1"
; (c1-a v4)      => "a1"
; (c2-b v4)      => "b2"

; (define v5 (make-compound-condition v2 v3))

; (c? v5)        => #t
; (c1? v5)       => #t
; (c2? v5)       => #t
; (c-x v5)       => "V2"
; (c1-a v5)      => "a3"
; (c2-b v5)      => "b2"

;; Local Variables:
;; mode: scheme
;; End:

;;; arch-tag: 774c4de9-d9f8-4754-8d40-38912ec7f3a1

[-- Attachment #4: Type: text/plain, Size: 270 bytes --]


Cheers, Andy
-- 
Andreas Rottmann         | Rotty@ICQ      | 118634484@ICQ | a.rottmann@gmx.at
http://yi.org/rotty      | GnuPG Key: http://yi.org/rotty/gpg.asc
Fingerprint              | DFB4 4EB4 78A4 5EEE 6219  F228 F92F CFC5 01FD 5B62

Make free software, not war!

[-- Attachment #5: Type: text/plain, Size: 139 bytes --]

_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user