Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add SRFI 35 support #1008

Merged
merged 3 commits into from
Nov 2, 2024
Merged

Add SRFI 35 support #1008

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
3777c1b
Add SRFI 35 support
dpk Oct 26, 2024
76f35bc
Define define-condition-type/constructor with syntax-rules
dpk Oct 27, 2024
2781739
Move REPL condition printing into the SRFI 35 implementation
dpk Nov 2, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
24 changes: 24 additions & 0 deletions lib/srfi/35.sld
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,24 @@
(define-library (srfi 35)
(import (srfi 35 internal))
(export make-condition-type
condition-type?
make-condition
condition?
condition-has-type?
condition-ref
make-compound-condition
extract-condition
define-condition-type
condition

&condition

&message
message-condition?
condition-message

&serious
serious-condition?

&error
error?))
249 changes: 249 additions & 0 deletions lib/srfi/35/internal.scm
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,249 @@
(define-record-type Simple-Condition
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I have to think about this, but long term it may be better to unify the native exceptions with Simple-Condition.

Copy link
Contributor Author

@dpk dpk Oct 28, 2024 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I assumed this would be too much core change for you, but I’m happy to consider implementing that as an alternative approach if you’d be okay with it.

(make-simple-condition)
simple-condition?)

(define-record-type Compound-Condition
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

On reviewing the SRFI I'm rather unhappy with it because of this distinction. It's ad-hoc and leads to a lot of ambiguity which doesn't exist in other exception systems. Cleaner is to always have one type which may have fields referring to other types (e.g. the underlying causes). I guess this was meant to make up for the lack of multiple inheritance.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If it’s any consolation, if you only use the (srfi 35) interface or the (rnrs conditions) interface, the representational distinction is pretty much non-observable. It’s only because (srfi 35 internal) wants to export everything needed to implement both interfaces (and, until you suggested the change below, (chibi repl) printing of conditions as well) that that library exposes the two different record types.

The ‘pretty much’ is because R6RS says a &condition is a non-sealed, non-opaque record type with no fields. (This is what requires implementing it this way for R6RS support, rather than the way chosen by the SRFI 35 sample implementation where the representations of simple and compound conditions are unified.) If you go in through the back door and make a record-predicate/rtd-predicate or a record-accessor/rtd-accessor for a condition type, you will find that it only works on simple conditions of that type – you have to use condition-predicate and condition-accessor instead. That’s the only place the representation breaks down.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The model is not quite multiple inheritance, because by design the set of simple conditions that makes up each compound condition is specific to the instance, not to the type as a whole.

Also, like consing onto an alist, it has an historical property: if an exception handler adds a new component before re-raising and the new component has a type (or supertype) which was already in the compound condition, the old component can still be accessed through the simple-conditions procedure.

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Sorry, I wasn't clear in my complaint. The complaint is in the existence of, and design of, compound conditions, not any implementation details.

The fundamental problem is that in SRFI 35 a given condition doesn't have any single, or even most specific, type. You move the burden of taking apart and understanding the condition to the call site, which isn't in general prepared or qualified to deal with this. Instead the code raising the condition should take care to choose a single most appropriate type. If there is a root cause it can be attached as a field, so that where it really matters the caller can unwrap and understand the condition in more detail.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The SRFI 35/R6RS solution works in practice, IMO, but I understand it is not flawless. Consider, for example, a raised condition of the form (condition (make-error) (make-irritants 'foo 'bar)). Let us assume that this exception is intercepted by an exception handler deciding that it should be a more serious condition for some reasons. So it wraps the condition by extending the compound condition which yields a new condition of the form (condition (make-violation) (make-irritants 'more-info) (make-error) (make-irritants 'foo 'bar)). With this model, it is not apparent which irritants belong to which part of the condition.

(%make-compound-condition components)
compound-condition?
(components compound-condition-components))

(define (make-condition-type id parent field-names)
(make-rtd id
(list->vector
(map
(lambda (field-name)
(list 'immutable field-name))
field-names))
parent))

(define (condition? obj)
(or (simple-condition? obj)
(compound-condition? obj)))

(define (condition-type? obj)
(condition-subtype? obj Simple-Condition))

(define (condition-subtype? maybe-child-ct maybe-parent-ct)
(and (rtd? maybe-child-ct)
(or (eqv? maybe-child-ct maybe-parent-ct)
(condition-subtype? (rtd-parent maybe-child-ct)
maybe-parent-ct))))

(define (condition-type-ancestors ct)
(unfold (lambda (a) (not (condition-type? a)))
(lambda (a) a)
(lambda (a) (rtd-parent a))
ct))

(define (condition-type-common-ancestor ct_1 ct_2)
(let ((ct_1-as (condition-type-ancestors ct_1))
(ct_2-as (condition-type-ancestors ct_2)))
(find (lambda (a)
(memv a ct_2-as))
ct_1-as)))

(define (make-condition ct . plist)
(define *undef* (cons '*undef* '()))
(let* ((field-names (rtd-all-field-names ct))
(field-values (make-vector (vector-length field-names) *undef*)))
(let loop ((property plist))
(if (null? property)
(cond ((vector-any (lambda (name value)
(and (eq? value *undef*) name))
field-names
field-values)
=> (lambda (undef-field-name)
(error "make-condition: value not given for field"
undef-field-name
ct)))
(else
(apply (rtd-constructor ct) (vector->list field-values))))
(let ((idx (vector-index (lambda (x) (eq? x (car property)))
field-names)))
(if idx
(begin
(vector-set! field-values idx (cadr property))
(loop (cddr property)))
(error "make-condition: unknown field" (car property))))))))

(define (make-compound-condition . cs)
(if (= (length cs) 1)
(car cs)
;; SRFI 35 requires at least one component, but R6RS doesn’t;
;; defer to R6RS’s less strict error checking (!)
(%make-compound-condition
(append-map
(lambda (c)
(if (simple-condition? c)
(list c)
(compound-condition-components c)))
cs))))

(define (condition-has-type? c ct)
(if (simple-condition? c)
(is-a? c ct)
(any
(lambda (comp) (condition-has-type? comp ct))
(compound-condition-components c))))

(define (condition-ref c field-name)
(if (simple-condition? c)
((rtd-accessor (record-rtd c) field-name) c)
(condition-ref
(find
(lambda (comp)
(find field-name
(vector->list
(rtd-all-field-names (record-rtd c)))))
(compound-condition-components c))
field-name)))

(define (simple-conditions c)
(if (simple-condition? c)
(list c)
(compound-condition-components c)))

(define (extract-condition c ct)
(if (and (simple-condition? c)
(condition-has-type? c ct))
c
(find
(lambda (comp)
(condition-has-type? comp ct))
(compound-condition-components ct))))

(define (condition-predicate ct)
(lambda (obj)
(and (condition? obj)
(condition-has-type? obj ct))))
(define (condition-accessor ct proc)
(lambda (c)
(cond ((and (simple-condition? c)
(condition-has-type? c ct))
(proc c))
((find (lambda (comp) (condition-has-type? comp ct))
(compound-condition-components c))
=> (lambda (comp)
(proc comp)))
(else (error "condition-accessor: condition does not have the right type"
c ct)))))

(define-syntax define-condition-type/constructor
(syntax-rules ()
((_ name parent constructor predicate
(field-name field-accessor) ...)
(begin
(define ct (make-condition-type 'name
parent
'(field-name ...)))
(define name ct)
(define constructor (rtd-constructor ct))
(define predicate (condition-predicate ct))
(define field-accessor
(condition-accessor ct
(rtd-accessor ct 'field-name))) ...))))

(define-syntax define-condition-type
(syntax-rules ()
((_ name parent predicate (field-name field-accessor) ...)
(define-condition-type/constructor
name parent blah-ignored predicate
(field-name field-accessor) ...))))

(define (%condition . specs)
(define (find-common-field-spec ct name)
(let loop ((more-specs specs))
(if (null? more-specs)
#f
(let* ((other-ct (caar more-specs))
(field-specs (cdar more-specs))
(a (condition-type-common-ancestor ct other-ct)))
(cond ((and (vector-index
(lambda (n)
(eq? n name))
(rtd-all-field-names a))
(assq name field-specs)))
(else (loop (cdr more-specs))))))))
(let loop ((more-specs specs)
(components '()))
(if (null? more-specs)
(apply make-compound-condition (reverse components))
(let* ((this-spec (car more-specs))
(ct (car this-spec))
(field-specs (cdr this-spec))
(field-names (rtd-all-field-names ct))
(field-values
(vector-map
(lambda (field-name)
(cond ((assq field-name field-specs) => cdr)
((find-common-field-spec ct field-name) => cdr)
(else
(error "condition: value not given for field"
field-name
ct))))
field-names)))
(loop
(cdr more-specs)
(cons
(apply (rtd-constructor ct) (vector->list field-values))
components))))))
(define-syntax condition
(syntax-rules ()
((_ (ct (field-name field-value) ...) ...)
(%condition (list ct (cons 'field-name field-value) ...) ...))))

(define &condition Simple-Condition)

(define-condition-type/constructor &message &condition
make-message-condition message-condition?
(message condition-message))

(define-condition-type/constructor &serious &condition
make-serious-condition serious-condition?)

(define-condition-type/constructor &error &serious
make-error error?)

;; (chibi repl) support
(define-method (repl-print-exception (exn condition?) (out output-port?))
(define components (simple-conditions exn))
(define n-components (length components))
(display "CONDITION: " out)
(display n-components out)
(display " component" out)
(if (not (= n-components 1)) (display "s" out))
(display "\n" out)
(for-each
(lambda (component idx)
(define component-type (record-rtd component))
(display " " out)
(display idx out)
(display ". " out)
(display (rtd-name component-type) out)
(display "\n" out)
(let loop ((as (reverse
(condition-type-ancestors component-type)))
(idx 0))
(if (not (null? as))
(let ((a (car as)))
(let a-loop ((fields (vector->list (rtd-field-names a)))
(idx idx))
(if (null? fields)
(loop (cdr as) idx)
(begin
(display " " out)
(display (if (pair? (car fields))
(car (cdar fields))
(car fields))
out)
(if (not (eqv? a component-type))
(begin
(display " (" out)
(display (rtd-name a) out)
(display ")" out)))
(display ": " out)
(write (slot-ref component-type component idx) out)
(display "\n" out)
(a-loop (cdr fields) (+ idx 1)))))))))
components
(iota n-components 1)))
48 changes: 48 additions & 0 deletions lib/srfi/35/internal.sld
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,48 @@
(define-library (srfi 35 internal)
(import (except (scheme base)
define-record-type
;; exclude (srfi 1 immutable) duplicate imports:
map cons list append reverse)
(scheme write)
(only (chibi)
slot-ref
is-a?)
(only (chibi repl) repl-print-exception)
(only (chibi generic) define-method)
;; don’t let people go messing with a compound condition
;; components list:
(srfi 1 immutable)
(srfi 99)
(srfi 133))
(export make-condition-type
condition?
condition-type?
condition-subtype?
make-condition
make-compound-condition
condition-has-type?
condition-ref
simple-conditions
extract-condition
condition-predicate
condition-accessor
define-condition-type/constructor
define-condition-type
condition

&condition

&message
make-message-condition
message-condition?
condition-message

&serious
make-serious-condition
serious-condition?

&error
make-error
error?)

(include "internal.scm"))
Loading
Loading