blob: 907decd5f0d771850766e91ca10b7edb6ae32d38 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
|
(define-library (cuprate implementation foment)
(import (foment base) (scheme base) (srfi 166) (srfi 225) (srfi 128) (srfi 125))
(export pretty-print default-test-dto
alist->default-dictionary
make-eq-map implementation-rewriters)
(include "srfi-125-eq-map.scm")
(begin
(define (pretty-print obj)
(show #t (pretty obj))
(newline))
(define default-test-dto eqv-alist-dto)
(define (alist->default-dictionary x) x)
(define (default-on-error rewrite error)
(let ((msg (error-object-message error))
(irritants (error-object-irritants error)))
`(error (type ,(rewrite (error-object-type error)))
(who ,(rewrite (error-object-who error)))
(kind ,(rewrite (error-object-kind error)))
(msg ,(rewrite (error-object-message error)))
(irritants ,@(map rewrite (error-object-irritants error))))))
(define implementation-rewriters
(list (cons error-object? default-on-error)))))
|
