diff --git a/sugar/debug.rkt b/sugar/debug.rkt index 42778c9..98d745f 100644 --- a/sugar/debug.rkt +++ b/sugar/debug.rkt @@ -5,3 +5,80 @@ (provide+safe report report/line report/file report* report*/line report*/file report-apply repeat time-repeat time-repeat* compare) + + + +(module reader racket/base + (require syntax/module-reader racket/syntax) + (provide (rename-out [debug-read read] + [debug-read-syntax read-syntax] + [debug-get-info get-info])) + + (define (make-debug-readtable [rt (current-readtable)]) + (make-readtable rt + #\^ 'non-terminating-macro report-proc)) + + + (define (wrap-reader reader) + (define (rd . args) + (define intro (make-syntax-introducer)) + (parameterize ([current-readtable (make-debug-readtable (current-readtable))] + [current-syntax-introducer intro]) + (define stx (apply reader args)) + (if (syntax? stx) + (intro stx) + stx))) + rd) + + + (define current-syntax-introducer + (make-parameter (λ (x) x))) + + + (define (report-proc c in src ln col pos) + (define c2 (peek-char in)) + (define c3 (peek-char in 1)) + (define intro (current-syntax-introducer)) + (cond [(and (char=? c3 #\^) (char=? c2 #\^)) + (read-char in) + (read-char in) + (define/with-syntax stx (intro (read-syntax/recursive src in))) + (intro + #'(let () + (local-require (only-in sugar/debug [report/file report/file])) + (report/file stx)))] + [(char=? c2 #\^) + (read-char in) + (define/with-syntax stx (intro (read-syntax/recursive src in))) + (intro + #'(let () + (local-require (only-in sugar/debug [report/line report/line])) + (report/line stx)))] + [else + (define/with-syntax stx (intro (read-syntax/recursive src in))) + (intro + #'(let () + (local-require (only-in sugar/debug [report report])) + (report stx)))])) + + + (define-values (debug-read debug-read-syntax debug-get-info) + (make-meta-reader + 'sugar/debug/lang + "language path" + (lambda (bstr) + (let* ([str (bytes->string/latin-1 bstr)] + [sym (string->symbol str)]) + (and (module-path? sym) + (vector + ;; try submod first: + `(submod ,sym reader) + ;; fall back to /lang/reader: + (string->symbol (string-append str "/lang/reader")))))) + wrap-reader + wrap-reader + (lambda (proc) + (lambda (key defval) + (define (fallback) (if proc (proc key defval) defval)) + (case key + [else (fallback)])))))) \ No newline at end of file diff --git a/sugar/debug/lang/lang/reader.rkt b/sugar/debug/lang/lang/reader.rkt deleted file mode 100644 index 60fe625..0000000 --- a/sugar/debug/lang/lang/reader.rkt +++ /dev/null @@ -1,28 +0,0 @@ -(module reader racket/base - (require syntax/module-reader - (only-in "../../reader.rkt" make-debug-readtable wrap-reader)) - - (provide (rename-out [debug-read read] - [debug-read-syntax read-syntax] - [debug-get-info get-info])) - - (define-values (debug-read debug-read-syntax debug-get-info) - (make-meta-reader - 'sugar/debug/lang - "language path" - (lambda (bstr) - (let* ([str (bytes->string/latin-1 bstr)] - [sym (string->symbol str)]) - (and (module-path? sym) - (vector - ;; try submod first: - `(submod ,sym reader) - ;; fall back to /lang/reader: - (string->symbol (string-append str "/lang/reader")))))) - wrap-reader - wrap-reader - (lambda (proc) - (lambda (key defval) - (define (fallback) (if proc (proc key defval) defval)) - (case key - [else (fallback)])))))) diff --git a/sugar/debug/reader.rkt b/sugar/debug/reader.rkt deleted file mode 100644 index 5675652..0000000 --- a/sugar/debug/reader.rkt +++ /dev/null @@ -1,42 +0,0 @@ -#lang racket/base - -(provide make-debug-readtable wrap-reader) - -(require racket/syntax) - -(define (make-debug-readtable [rt (current-readtable)]) - (make-readtable rt - #\^ 'dispatch-macro report-proc - )) - -(define current-syntax-introducer - (make-parameter (λ (x) x))) - -(define (report-proc c in src ln col pos) - (define c2 (peek-char in)) - (define intro (current-syntax-introducer)) - (cond [(char=? c2 #\^) - (read-char in) - (define/with-syntax stx (intro (read-syntax/recursive src in))) - (intro - #'(let () - (local-require (only-in sugar/debug [report/line report/line])) - (report/line stx)))] - [else - (define/with-syntax stx (intro (read-syntax/recursive src in))) - (intro - #'(let () - (local-require (only-in sugar/debug [report report])) - (report stx)))])) - -(define (wrap-reader reader) - (define (rd . args) - (define intro (make-syntax-introducer)) - (parameterize ([current-readtable (make-debug-readtable (current-readtable))] - [current-syntax-introducer intro]) - (define stx (apply reader args)) - (if (syntax? stx) - (intro stx) - stx))) - rd) - diff --git a/sugar/test/debug-meta-lang.rkt b/sugar/test/debug-meta-lang.rkt index 30bdf1c..951aa5d 100644 --- a/sugar/test/debug-meta-lang.rkt +++ b/sugar/test/debug-meta-lang.rkt @@ -1,4 +1,4 @@ -#lang sugar/debug/lang racket +#lang sugar/debug racket (require rackunit) (let ([out (open-output-string)] [let "something else"] @@ -6,10 +6,10 @@ [only-in "completely unexpected!"] [report "well, not really"]) (parameterize ([current-error-port out]) - #^5) + ^5) (check-equal? (get-output-string out) "5 = 5\n")) (let ([out (open-output-string)] [report/line "outta the blue!"]) (parameterize ([current-error-port out]) - #^^5) + ^^5) (check-equal? (get-output-string out) "5 = 5 on line 14\n")) diff --git a/typed/sugar/debug.rkt b/typed/sugar/debug.rkt index 683b2aa..bd5b1e2 100644 --- a/typed/sugar/debug.rkt +++ b/typed/sugar/debug.rkt @@ -29,7 +29,7 @@ (with-syntax ([file (syntax-source #'expr)] [line (syntax-line #'expr)]) #'(let ([expr-result expr]) - (eprintf "~a = ~v on line ~v in \"~a\"\n" 'name expr-result line file) + (eprintf "~a = ~v on line ~v in \"~a\"\n" 'name expr-result line 'file) expr-result))]))