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

Last change on this file since 38965 was 38965, checked in by Kon Lovett, 2 months ago

add -strict-types, remove redudant -local, update test runner, type is interface

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