suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

provide a more helpful message on failure of syntax traversal in the stepper

Browse Source
This commit is contained in:
John Clements 2014-04-10 16:02:58 -07:00
parent 50aae13378
commit 784bda15a8
1 changed files with 32 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
pkgs/htdp-pkgs/htdp-lib/stepper/private/shared.rkt
View File

@ -405,23 +405,39 @@
[(both-r) (lambda (stx a b) b)]
[else (error 'up-mapping "unexpected symbol in up-mapping (2): ~v" fn)])]))
(define (down-mapping fn)
(case fn
[(car) car]
[(cdr) cdr]
[(syntax-e) syntax-e]
[else (error 'down-mapping "called on something other than 'car, 'cdr, & 'syntax-e: ~v" fn)]))
;; like car, but provide a useful error message if given a non-pair
(define (noisy-car arg)
(cond [(pair? arg) (car arg)]
[else (raise-argument-error 'noisy-car "pair in syntax traversal" 0 arg)]))
(define (update fn-list val fn traversal)
(if (null? fn-list)
(fn val)
(let ([up (up-mapping traversal (car fn-list))])
(case (car fn-list)
[(both-l both-r) (up val
(update (cadr fn-list) (car val) fn traversal)
(update (caddr fn-list) (cdr val) fn traversal))]
[else (let ([down (down-mapping (car fn-list))])
(up val (update (cdr fn-list) (down val) fn traversal)))]))))
;; like cdr, but provide a useful error message if given a non-pair
(define (noisy-cdr arg)
(cond [(pair? arg) (cdr arg)]
[else (raise-argument-error 'noisy-car "pair in syntax traversal" 0 arg)]))
;; like syntax-e, but provide a useful error message if given a non-syntax-object
(define (noisy-syntax-e arg)
(cond [(syntax? arg) (syntax-e arg)]
[else (raise-argument-error 'noisy-car "syntax object in syntax traversal" 0 arg)]))
;; map a symbol in '(car cdr syntax-e) to the appropriate projector
(define (down-mapping fn)
(case fn
[(car) noisy-car]
[(cdr) noisy-cdr]
[(syntax-e) noisy-syntax-e]
[else (error 'down-mapping "called on something other than 'car, 'cdr, & 'syntax-e: ~v" fn)]))
(define (update fn-list val fn traversal)
(if (null? fn-list)
(fn val)
(let ([up (up-mapping traversal (car fn-list))])
(case (car fn-list)
[(both-l both-r) (up val
(update (cadr fn-list) (car val) fn traversal)
(update (caddr fn-list) (cdr val) fn traversal))]
[else (let ([down (down-mapping (car fn-list))])
(up val (update (cdr fn-list) (down val) fn traversal)))]))))
#;(display (equal? (update '(cdr cdr car both-l (car) (cdr))