Remove dependencies on unstable/error.
Involved moving part of its implementation to the db collection.
This commit is contained in:
parent
689c294e91
commit
aa0823daf6
|
@ -2,7 +2,6 @@
|
||||||
(require racket/vector
|
(require racket/vector
|
||||||
racket/class
|
racket/class
|
||||||
racket/promise
|
racket/promise
|
||||||
unstable/error
|
|
||||||
"interfaces.rkt"
|
"interfaces.rkt"
|
||||||
(only-in "sql-data.rkt" sql-null sql-null?))
|
(only-in "sql-data.rkt" sql-null sql-null?))
|
||||||
(provide connected?
|
(provide connected?
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
(require racket/class
|
(require racket/class
|
||||||
|
racket/list
|
||||||
racket/serialize
|
racket/serialize
|
||||||
unstable/error)
|
racket/string)
|
||||||
(provide connection<%>
|
(provide connection<%>
|
||||||
dbsystem<%>
|
dbsystem<%>
|
||||||
prepared-statement<%>
|
prepared-statement<%>
|
||||||
|
@ -200,7 +201,95 @@ For SQLite, use symbol instead of SQLSTATE string.
|
||||||
error/want-cursor
|
error/want-cursor
|
||||||
error/column-count
|
error/column-count
|
||||||
error/row-count
|
error/row-count
|
||||||
error/statement-binding-args)
|
error/statement-binding-args
|
||||||
|
;; other modules also define some error reporting
|
||||||
|
compose-error-message
|
||||||
|
error*)
|
||||||
|
|
||||||
|
(define (error* who message
|
||||||
|
#:continued [continued-message null]
|
||||||
|
. field+detail-list)
|
||||||
|
(raise
|
||||||
|
(exn:fail
|
||||||
|
(compose* who message
|
||||||
|
continued-message
|
||||||
|
(field+detail-list->table 'error* field+detail-list null))
|
||||||
|
(current-continuation-marks))))
|
||||||
|
|
||||||
|
;; compose-error-message : .... -> string
|
||||||
|
(define (compose-error-message who message
|
||||||
|
#:continued [continued-message null]
|
||||||
|
. field+detail-list)
|
||||||
|
(define details
|
||||||
|
(field+detail-list->table 'compose-error-message field+detail-list null))
|
||||||
|
(compose* who message continued-message details))
|
||||||
|
|
||||||
|
(define (compose* who message continued-message details)
|
||||||
|
(let* ([parts (apply append
|
||||||
|
(for/list ([detail (in-list details)])
|
||||||
|
(let* ([field+opts (car detail)]
|
||||||
|
[field (if (pair? field+opts) (car field+opts) field+opts)]
|
||||||
|
[options (if (pair? field+opts) (cdr field+opts) '())]
|
||||||
|
[value (cdr detail)])
|
||||||
|
(compose-detail* field options value))))]
|
||||||
|
[parts (let loop ([continued continued-message])
|
||||||
|
(cond [(pair? continued) (list* "\n " (car continued) (loop (cdr continued)))]
|
||||||
|
[(string? continued) (loop (list continued))]
|
||||||
|
[(null? continued) parts]))]
|
||||||
|
[parts (list* message (if (null? continued-message) "" ";") parts)]
|
||||||
|
[parts (if who
|
||||||
|
(list* (symbol->string who) ": " parts)
|
||||||
|
parts)])
|
||||||
|
(apply string-append parts)))
|
||||||
|
|
||||||
|
(define (compose-detail* field options value)
|
||||||
|
(let* ([value? (memq 'value options)]
|
||||||
|
[multi? (memq 'multi options)]
|
||||||
|
[maybe? (memq 'maybe options)]
|
||||||
|
[noindent? (memq 'noindent options)]
|
||||||
|
[convert-value0
|
||||||
|
(cond [value?
|
||||||
|
(lambda (v) ((error-value->string-handler) v (error-print-width)))]
|
||||||
|
[else
|
||||||
|
(lambda (v) (format "~a" v))])]
|
||||||
|
[convert-value
|
||||||
|
(if noindent?
|
||||||
|
(lambda (v indent) (list (convert-value0 v)))
|
||||||
|
(lambda (v indent)
|
||||||
|
(let* ([s (convert-value0 v)]
|
||||||
|
[lines (string-split s #rx"[\n]" #:trim? #f)]
|
||||||
|
[spacing
|
||||||
|
(case indent
|
||||||
|
((3) "\n ") ;; common case, make constant
|
||||||
|
(else (string-append "\n" (make-string indent #\space))))])
|
||||||
|
(add-between lines spacing))))])
|
||||||
|
(cond [(and (or maybe? multi? (not value?))
|
||||||
|
(not value))
|
||||||
|
null]
|
||||||
|
[(and maybe? multi?
|
||||||
|
(null? value))
|
||||||
|
null]
|
||||||
|
[multi?
|
||||||
|
(list* "\n " field ": "
|
||||||
|
(let value-loop ([value value])
|
||||||
|
(cond [(pair? value)
|
||||||
|
(list* "\n "
|
||||||
|
(append (convert-value (car value) 3)
|
||||||
|
(value-loop (cdr value))))]
|
||||||
|
[(null? value)
|
||||||
|
null])))]
|
||||||
|
[else
|
||||||
|
(list* "\n " field ": "
|
||||||
|
(convert-value value (+ 4 (string-length field))))])))
|
||||||
|
|
||||||
|
(define (field+detail-list->table who lst onto)
|
||||||
|
(cond [(null? lst) onto]
|
||||||
|
[else
|
||||||
|
(let ([field (car lst)]
|
||||||
|
[value (cadr lst)])
|
||||||
|
(cons (cons field value)
|
||||||
|
(field+detail-list->table who (cddr lst) onto)))]))
|
||||||
|
|
||||||
|
|
||||||
(define (error/internal fsym fmt . args)
|
(define (error/internal fsym fmt . args)
|
||||||
(error* fsym "internal error"
|
(error* fsym "internal error"
|
||||||
|
|
|
@ -3,7 +3,6 @@
|
||||||
ffi/unsafe
|
ffi/unsafe
|
||||||
ffi/unsafe/atomic
|
ffi/unsafe/atomic
|
||||||
ffi/unsafe/custodian
|
ffi/unsafe/custodian
|
||||||
unstable/error
|
|
||||||
"../generic/interfaces.rkt"
|
"../generic/interfaces.rkt"
|
||||||
"../generic/common.rkt"
|
"../generic/common.rkt"
|
||||||
"../generic/prepared.rkt"
|
"../generic/prepared.rkt"
|
||||||
|
|
Loading…
Reference in New Issue
Block a user