source: project/release/5/condition-utils/trunk/condition-utils.scm @ 38466

Last change on this file since 38466 was 38466, checked in by Kon Lovett, 7 months ago

update comment, style

File size: 4.8 KB
Line 
1;;;; condition-utils.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, May '17
4;;;; Kon Lovett, Aug '14
5;;;; Kon Lovett, Jun '13
6;;;; Kon Lovett, Aug '10
7;;;; Kon Lovett, Apr '09
8
9(declare
10  (bound-to-procedure ##sys#really-print-call-chain) )
11
12(module condition-utils
13
14(;export
15  ;
16  call-chain?
17  ;
18  condition-irritants
19  ;
20  make-condition+
21  condition-predicate*
22  condition-property-accessor*
23  (make-condition-predicate condition-predicate*)
24  (make-condition-property-accessor condition-property-accessor*)
25  ;
26  write-condition)
27
28(import scheme)
29(import (chicken base))
30(import (chicken fixnum))
31(import (chicken condition))
32(import (chicken syntax))
33(import (chicken type))
34(import (only (chicken string) ->string))
35(import (only (chicken format) format))
36(import (only (chicken port) call-with-output-string))
37(import (only (srfi 69) make-hash-table hash-table-ref/default hash-table-set!))
38(import (only (srfi 1) concatenate))
39(import condition-utils-support)
40
41;;;
42
43; Symbols are convention. Any object supported.
44
45#; ;UNUSED
46(define (check-kind loc obj)
47  #;(check-symbol loc obj 'property-kind)
48  obj )
49
50#; ;UNUSED
51(define (check-property-tag loc obj)
52  #;(check-symbol loc obj 'property-tag)
53  obj )
54
55;;;
56
57;condition->plist
58;condition->alist
59
60;; All condition properties
61
62(: condition-irritants (condition --> list))
63;
64;((exn (arguments (test)) (message "test") (location test)) (test) (extra (test 23)))
65;=>
66;((arguments (test)) (message "test") (location test) (test 23))
67;
68(define (condition-irritants cnd)
69  ;indifferent to plist vs alist representation of condition-properties
70  ;from 'condition->list'.
71  (concatenate (map cdr (condition->list cnd))) )
72
73;; Condition from condition expression; composite when indicated
74
75(: make-condition+ (#!rest --> condition))
76;
77(define (make-condition+ . cnds)
78  (let (
79    (ls (expand-property-conditions cnds)) )
80    (if (null? (cdr ls))
81      (car ls)
82      (apply make-composite-condition ls) ) ) )
83
84;; memeoized condition-predicate ctor
85
86(: condition-predicate* (symbol -> (* -> boolean : condition)))
87;
88(define condition-predicate*
89  (let ((+preds+ (make-hash-table eq?)))
90    (lambda (kind)
91      #;(check-kind 'condition-predicate* kind)
92      (or
93        (hash-table-ref/default +preds+ kind #f)
94        (let (
95          (pred (condition-predicate kind)) )
96          (hash-table-set! +preds+ kind pred)
97          pred ) ) ) ) )
98
99;; create composite condition-predicate
100
101;should this be a procedure?
102;kinda ugly when procedural since needs to loop over kinds
103
104(define-syntax make-condition-predicate
105  (syntax-rules ()
106    ((_ ?kind0 ...)
107      (lambda (obj)
108        (and
109          ((condition-predicate* '?kind0) obj)
110          ... ) ) ) ) )
111
112;; memeoized condition-property-accessor ctor
113
114(: condition-property-accessor* (symbol symbol #!optional * -> (procedure (condition) *)))
115;
116(define condition-property-accessor*
117  (let (
118    (+getters+ (make-hash-table eq?)) )
119    (lambda (kind prop #!optional dflt)
120      #;(check-kind 'condition-property-accessor* kind)
121      #;(check-property-tag 'condition-property-accessor* prop)
122      (or
123        (hash-table-ref/default +getters+ kind #f)
124        (let (
125          (key (cons kind prop))
126          (getter (condition-property-accessor kind prop dflt)) )
127          (hash-table-set! +getters+ key getter)
128          getter ) ) ) ) )
129
130;; create condition-property-accessor w/ "default" default
131
132;should this be a procedure?
133(define-syntax make-condition-property-accessor
134  (syntax-rules ()
135    ;
136    ((_ ?kind ?prop)
137      (make-condition-property-accessor ?kind ?prop #f) )
138    ;
139    ((_ ?kind ?prop ?dflt)
140      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
141
142;;
143
144(: call-chain? (* -> boolean : (list-of vector)))
145;
146(define (call-chain? x)
147  ;(or (null? x) (and (proper-list? x) (every vector? x)))
148  (or
149    (null? x) ;chain could be empty
150    (and (pair? x) (vector? (car x)))) )
151
152(: write-condition (condition #!optional output-port string -> void))
153;
154(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
155  (format port "~A: ~A"
156    header
157    (call-with-output-string
158      (lambda (p) (write-condition-list (condition->list cnd) p header)))) )
159
160;;;
161
162;;
163
164(: condition-property->string (condition symbol symbol * -> string))
165;
166(define (condition-property->string cnd kind prop #!optional (def ""))
167  (->string ((condition-property-accessor kind prop def) cnd)) )
168
169;;
170
171#; ;UNUSED
172(define (exn-prop->string prop)
173  (condition-property->string cnd 'exn prop) )
174
175#; ;UNUSED
176(define (write-error-message cnd port header)
177  (format port "~%~A(~A) ~A: ~A~%"
178    header
179    (exn-prop->string 'location)
180    (exn-prop->string 'message)
181    (exn-prop->string 'arguments)) )
182
183;;
184
185(define (subheader-string header)
186  (string-append (make-string (fx- (string-length header) 1) #\space) "+") )
187
188) ;module condition-utils
Note: See TracBrowser for help on using the repository browser.