source: project/release/4/error-utils/trunk/error-utils.scm @ 35182

Last change on this file since 35182 was 35182, checked in by kon, 5 months ago

better names, re-flow

File size: 3.4 KB
Line 
1;;;; error-utils.scm
2;;;; Kon Lovett, Aug '10
3;;;; Kon Lovett, may '17
4
5(module error-utils
6
7(;export
8  ;
9  error-format-procedure
10  ;
11  errorf
12  ;
13  error-print *error-print
14  errorf-print
15  ;
16  error/no-raise *error/no-raise errorf/no-raise)
17
18(import scheme  chicken)
19(use
20  (only extras format)
21  (only data-structures chop ->string string-intersperse)
22  (only (srfi 1) append!) )
23
24;;;
25
26;; Print error message but don't throw an exception
27;;
28(define (error-print . args)
29  (let-values (((port args) (error-port-args args)))
30    (*error-print args port) ) )
31
32;; Print error-style message to port
33;; unlike 'error' will print arguments when loc but no msg
34;;
35(define (*error-print args #!optional (port (current-error-port)))
36  (let-values (((loc msg args) (error-params args)))
37    (let (
38      (errmsg
39        (string-append
40          "\n"
41          "Error" (if (or loc msg) ": " "")
42          (if (and loc msg) (string-append "(" (->string loc) ")" " ") "")
43          (or (and msg (->string msg)) (and loc (->string loc)) "")
44          (cond
45            ((null? args)
46              "" )
47            ((null? (cdr args))
48              (string-append ": " (->sexpr-string (car args))) )
49            (else
50              ;leading empty string so leading newline
51              (string-intersperse (append '("") (map ->sexpr-string args)) "\n") ) )
52          "\n" )))
53      (display errmsg port) ) ) )
54
55;;
56(define (errorf . args)
57  (*errorf #f error args) )
58
59;;
60(define (errorf-print . args)
61  (let-values (((port args) (error-port-args args)))
62    (*errorf port error-print args) ) )
63
64;; Format procedure for error
65;;
66(define error-format-procedure
67  (make-parameter
68    format
69    (lambda (x)
70      (if (procedure? x)
71        x
72        (begin
73          (warning 'error-format-procedure "invalid procedure" x)
74          (error-format-procedure) ) ) ) ) )
75
76;;;
77
78;;
79(define (*errorf port proc args)
80  (let ((portarg (if port `(,port) '())))
81    (let-values (((loc fmt fmtargs) (error-params args)))
82      (let (
83        (err-args
84          (if (not fmt)
85            (append args portarg)
86            (let ((msg (apply (error-format-procedure) #f fmt fmtargs)))
87              (if loc
88                (append! `(,loc ,msg) portarg)
89                (append! `(,msg) portarg) ) ) ) ) )
90        (apply proc err-args) ) ) ) )
91
92;;
93(define (->sexpr-string obj)
94  ((error-format-procedure) #f "~S" obj) )
95
96;; Parse error style argument list into (values loc msg args)
97;;
98(define (error-params args)
99  (let* (
100    (loc
101      (and
102        (not (null? args))
103        (symbol? (car args)) (car args)) )
104    (msg
105      (if (not loc)
106        (and
107          (not (null? args))
108          (string? (car args)) (car args))
109        (and
110          (not (null? (cdr args)))
111          (string? (cadr args)) (cadr args)) ) )
112    (args
113      (cond
114        ((and loc msg)  (cddr args) )
115        ((or loc msg)   (cdr args) )
116        (else           args ) ) ) )
117    (values loc msg args) ) )
118
119;; Parse error-print style argument list into (values port args)
120;;
121(define (error-port-args args)
122  (let* (
123    (len (length args) )
124    (argls (and (<= 2 len) (chop args (fx- len 1))) )
125    (args (if argls (car argls) args) )
126    (port (and argls (caadr argls)) )
127    (args (if (port? port) args (append args (if port `(,port) '()))) )
128    (port (if (port? port) port (current-error-port)) ) )
129    (values port args) ) )
130
131;;;
132
133(define error/no-raise error-print)
134(define *error/no-raise *error-print)
135(define errorf/no-raise errorf-print)
136
137) ;module error-utils
Note: See TracBrowser for help on using the repository browser.