source: project/release/4/condition-utils/trunk/condition-utils.scm @ 29490

Last change on this file since 29490 was 29156, checked in by Kon Lovett, 7 years ago

add call-chain supp, use hash-table instead of alist, add module of condition predicates & accessors

File size: 3.6 KB
Line 
1;;;; condition-utils.scm
2;;;; Kon Lovett, Jun '13
3;;;; Kon Lovett, Aug '10
4;;;; Kon Lovett, Apr '09
5
6;; Issues
7;;
8
9(module condition-utils
10
11  (;export
12    ;
13    condition-irritants
14    make-condition+
15    condition-predicate*
16    condition-property-accessor*
17    (make-condition-predicate condition-predicate*)
18    (make-condition-property-accessor condition-property-accessor*)
19    ;
20    make-exn-condition
21    make-exn-condition+
22  )
23
24  (import scheme chicken)
25
26  (use srfi-1 srfi-69 #;type-checks)
27
28;;;
29
30; Symbols are convention. Any object supported.
31
32(define (check-kind loc obj)
33  #;(check-symbol loc obj 'property-kind)
34  (void) )
35
36(define (check-property-tag loc obj)
37  #;(check-symbol loc obj 'property-tag)
38  (void) )
39
40;;;
41
42;; Interpret condition expression
43
44;; <condition>  ->  <condition>
45;; <symbol>     ->  (make-property-condition <symbol>)
46;; <pair>       ->  (apply make-property-condition <pair>)
47;;
48;; (<symbol> [<symbol> <object>]...)
49
50(define (expand-property-conditions cnds)
51   (map (lambda (x)
52          (cond ((condition? x)  x )
53                ((symbol? x)     (make-property-condition x) )
54                ((pair? x)       (apply make-property-condition x) ) ) )
55        cnds) )
56
57;;;
58
59;; All condition properties
60
61(define (condition-irritants exn)
62  (fold
63    (lambda (kndlst lst) (append! lst (cdr kndlst)) )
64    '()
65    (condition->list exn)) )
66
67;; Condition from condition expression; composite when indicated
68
69(define (make-condition+ . cnds)
70  (let ((ls (expand-property-conditions cnds)))
71    (if (= 1 (length ls)) (car ls)
72    (apply make-composite-condition ls) ) ) )
73
74;;
75
76(define condition-predicate*
77  (let ((+preds+ (make-hash-table eq?)))
78    (lambda (kind)
79      #;(check-kind 'condition-predicate* kind)
80      (let ((p (hash-table-ref/default +preds+ kind #f)))
81        (or p
82            (let ((pred (condition-predicate kind)))
83              (hash-table-set! +preds+ kind pred)
84              pred ) ) ) ) ) )
85
86;;
87
88(define-syntax make-condition-predicate
89  (syntax-rules ()
90    ((_ ?kind0 ...)
91      (lambda (obj) (and ((condition-predicate* '?kind0) obj) ...) ) ) ) )
92
93;;
94
95(define condition-property-accessor*
96  (let ((+getters+ (make-hash-table eq?)))
97    (lambda (kind prop #!optional dflt)
98      #;(check-kind 'condition-property-accessor* kind)
99      #;(check-property-tag 'condition-property-accessor* prop)
100      (let* ((key (cons kind prop))
101             (p (hash-table-ref/default +getters+ kind #f)) )
102        (or p
103            (let ((getter (condition-property-accessor kind prop dflt)))
104              (hash-table-set! +getters+ key getter)
105              getter ) ) ) ) ) )
106
107;;
108
109(define-syntax make-condition-property-accessor
110  (syntax-rules ()
111
112    ((_ ?kind ?prop)
113      (make-condition-property-accessor ?kind ?prop #f) )
114
115    ((_ ?kind ?prop ?dflt)
116      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
117
118;;; EXN Condition
119
120;;
121
122(define (make-exn-condition #!optional (loc #f) (msg #f) (args #f) (calls #f))
123  (apply make-property-condition 'exn
124    (append!
125      (list 'location loc)
126      (list 'message (or msg ""))
127      (list 'arguments (or args '()))
128      (if calls (list 'call-chain calls) '()))) )
129
130;;
131
132(define (make-exn-condition+ loc msg args . cnds)
133  (define (call-chain? x)
134    ;(and (proper-list? x) (every vector? x))
135    (and
136      (pair? x)
137      (vector? (car x))) )
138  (let ((chn (and (not (null? cnds))
139                  (call-chain? (car cnds))
140                  (car cnds))))
141    (apply make-composite-condition
142           (apply make-exn-condition loc msg args (or chn '()))
143           (expand-property-conditions (if chn (cdr cnds) cnds))) ) )
144
145) ;module condition-utils
Note: See TracBrowser for help on using the repository browser.