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