From 7262d3a4631d6fd941ad3a80eaaaf533d4dc8380 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Sat, 2 Jan 2016 12:20:12 -0500 Subject: [PATCH] get rid of the let + local-require noise in output fixes https://github.com/AlexKnauth/debug/issues/4 --- debug/lang/reader.rkt | 87 ++++++++++++++++++++++++++++++------------- debug/test/test.rkt | 11 +++++- 2 files changed, 71 insertions(+), 27 deletions(-) diff --git a/debug/lang/reader.rkt b/debug/lang/reader.rkt index 69aec49..2d57f4e 100644 --- a/debug/lang/reader.rkt +++ b/debug/lang/reader.rkt @@ -40,10 +40,29 @@ stx))) rd) - +;; current-syntax-introducer : (Parameterof [Syntax -> Syntax]) (define current-syntax-introducer (make-parameter (λ (x) x))) +;; current-intro-id-syntax : (Parameterof (U #false Syntax)) +;; A value of #false means that it is not nested within another debug expression +;; A syntax object means that it is nested within another debug expression, +;; where the macros are already bound, and it should use `datum->syntax` with +;; the syntax object value as the lexical context context. +(define current-intro-id-syntax + (make-parameter #false)) + +;; maybe-add-let +(define (maybe-add-local-require ctxt debug-expr) + (define/with-syntax expr debug-expr) + (cond [(current-intro-id-syntax) + #'expr] + [else + (define/with-syntax debug/report (datum->syntax ctxt 'debug/report)) + #'(let () + (local-require debug/report) + expr)])) + (define (report-proc c in src ln col pos) (define c2 (peek-char in)) @@ -54,50 +73,68 @@ (read-char in) (read-char in) (read-char in) + (define/with-syntax ctxt (or (current-intro-id-syntax) #'here)) + (define/with-syntax report/file (datum->syntax #'ctxt 'report/file)) (define/with-syntax name (intro (read-syntax/recursive src in))) - (define/with-syntax stx (intro (read-syntax/recursive src in))) + (define/with-syntax stx + (parameterize ([current-intro-id-syntax #'ctxt]) + (intro (read-syntax/recursive src in)))) (intro - #'(let () - (local-require (only-in debug/report [report/file report/file])) - (report/file stx name)))] + (maybe-add-local-require #'ctxt + #'(report/file stx name)))] [(and (char=? c2 report-char) (char=? c3 name-char)) (read-char in) (read-char in) + (define/with-syntax ctxt (or (current-intro-id-syntax) #'here)) + (define/with-syntax report/line (datum->syntax #'ctxt 'report/line)) (define/with-syntax name (intro (read-syntax/recursive src in))) - (define/with-syntax stx (intro (read-syntax/recursive src in))) + (define/with-syntax stx + (parameterize ([current-intro-id-syntax #'ctxt]) + (intro (read-syntax/recursive src in)))) (intro - #'(let () - (local-require (only-in debug/report [report/line report/line])) - (report/line stx name)))] + (maybe-add-local-require #'ctxt + #'(report/line stx name)))] [(char=? c2 name-char) (read-char in) + (define/with-syntax ctxt (or (current-intro-id-syntax) #'here)) + (define/with-syntax report (datum->syntax #'ctxt 'report)) (define/with-syntax name (intro (read-syntax/recursive src in))) - (define/with-syntax stx (intro (read-syntax/recursive src in))) + (define/with-syntax stx + (parameterize ([current-intro-id-syntax #'ctxt]) + (intro (read-syntax/recursive src in)))) (intro - #'(let () - (local-require (only-in debug/report [report report])) - (report stx name)))] + (maybe-add-local-require #'ctxt + #'(report stx name)))] [(and (char=? c3 report-char) (char=? c2 report-char)) (read-char in) (read-char in) - (define/with-syntax stx (intro (read-syntax/recursive src in))) + (define/with-syntax ctxt (or (current-intro-id-syntax) #'here)) + (define/with-syntax report/file (datum->syntax #'ctxt 'report/file)) + (define/with-syntax stx + (parameterize ([current-intro-id-syntax #'ctxt]) + (intro (read-syntax/recursive src in)))) (intro - #'(let () - (local-require (only-in debug/report [report/file report/file])) - (report/file stx)))] + (maybe-add-local-require #'ctxt + #'(report/file stx)))] [(char=? c2 report-char) (read-char in) - (define/with-syntax stx (intro (read-syntax/recursive src in))) + (define/with-syntax ctxt (or (current-intro-id-syntax) #'here)) + (define/with-syntax report/line (datum->syntax #'ctxt 'report/line)) + (define/with-syntax stx + (parameterize ([current-intro-id-syntax #'ctxt]) + (intro (read-syntax/recursive src in)))) (intro - #'(let () - (local-require (only-in debug/report [report/line report/line])) - (report/line stx)))] + (maybe-add-local-require #'ctxt + #'(report/line stx)))] [else - (define/with-syntax stx (intro (read-syntax/recursive src in))) + (define/with-syntax ctxt (or (current-intro-id-syntax) #'here)) + (define/with-syntax report (datum->syntax #'ctxt 'report)) + (define/with-syntax stx + (parameterize ([current-intro-id-syntax #'ctxt]) + (intro (read-syntax/recursive src in)))) (intro - #'(let () - (local-require (only-in debug/report [report report])) - (report stx)))])) + (maybe-add-local-require #'ctxt + #'(report stx)))])) (define-values (debug-read debug-read-syntax debug-get-info) diff --git a/debug/test/test.rkt b/debug/test/test.rkt index 5f8bfa6..bee6fb2 100644 --- a/debug/test/test.rkt +++ b/debug/test/test.rkt @@ -1,6 +1,6 @@ #lang debug racket/base -;; from mbutterick/sugar, sugar/test/debug-meta-lang.rkt +;; originally from mbutterick/sugar, sugar/test/debug-meta-lang.rkt ;; https://github.com/mbutterick/sugar/blob/0ffe3173879cef51d29b4c91a336a4de6c3f8ef8/sugar/test/debug-meta-lang.rkt (require rackunit @@ -27,10 +27,17 @@ #RRN x 5) (check-equal? (get-output-string out) "5 = 5 on line 26\nx = 5 on line 27\n")) +(let ([out (open-output-string)]) + (parameterize ([current-error-port out]) + #RR (+ 1 2 #R 5 + #RN x (* 1 2 3))) + (check-equal? (get-output-string out) + "5 = 5\nx = 6\n(+ 1 2 (report 5) (report (* 1 2 3) x)) = 14 on line 32\n")) + (begin-for-syntax (begin-for-syntax (begin-for-syntax (let ([out (open-output-string)]) (parameterize ([current-error-port out]) #RR5) - (check-equal? (get-output-string out) "5 = 5 on line 35\n"))))) + (check-equal? (get-output-string out) "5 = 5 on line 42\n")))))