diff --git a/debug/lang/reader.rkt b/debug/lang/reader.rkt new file mode 100644 index 0000000..9b4570b --- /dev/null +++ b/debug/lang/reader.rkt @@ -0,0 +1,93 @@ +#lang racket/base + +(provide (rename-out [debug-read read] + [debug-read-syntax read-syntax] + [debug-get-info get-info])) + +(require (only-in syntax/module-reader make-meta-reader) + racket/syntax + version/utils + syntax/parse/define + (for-syntax racket/base racket/list)) + +;; from mbutterick/sugar, sugar/debug.rkt, reader submodule +;; https://github.com/mbutterick/sugar/blob/0ffe3173879cef51d29b4c91a336a4de6c3f8ef8/sugar/debug.rkt + +(define report-char #\R) + +(define-simple-macro (require-a-lot require-spec) + #:with [i ...] (range -10 11) + (require (for-meta i require-spec) ...)) + +(require-a-lot racket/base) + +(define (make-debug-readtable [rt (current-readtable)]) + (make-readtable rt report-char 'dispatch-macro report-proc)) + +(define (wrap-reader reader) + (define (rd . args) + (define intro + (cond [(procedure-arity-includes? make-syntax-introducer 1) + (make-syntax-introducer #t)] + [else + (make-syntax-introducer)])) + (parameterize ([current-readtable (make-debug-readtable (current-readtable))] + [current-syntax-introducer intro]) + (define stx (apply reader args)) + (if (and (syntax? stx) (version<=? "6.2.900.4" (version))) + (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 report-char) (char=? c2 report-char)) + (read-char in) + (read-char in) + (define/with-syntax stx (intro (read-syntax/recursive src in))) + (intro + #'(let () + (local-require (only-in debug/report [report/file report/file])) + (report/file stx)))] + [(char=? c2 report-char) + (read-char in) + (define/with-syntax stx (intro (read-syntax/recursive src in))) + (intro + #'(let () + (local-require (only-in debug/report [report/line report/line])) + (report/line stx)))] + [else + (define/with-syntax stx (intro (read-syntax/recursive src in))) + (intro + #'(let () + (local-require (only-in debug/report [report report])) + (report stx)))])) + + +(define-values (debug-read debug-read-syntax debug-get-info) + (make-meta-reader + 'debug + "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/debug/test/test.rkt b/debug/test/test.rkt new file mode 100644 index 0000000..3b2348b --- /dev/null +++ b/debug/test/test.rkt @@ -0,0 +1,34 @@ +#lang debug racket/base + +;; from mbutterick/sugar, sugar/test/debug-meta-lang.rkt +;; https://github.com/mbutterick/sugar/blob/0ffe3173879cef51d29b4c91a336a4de6c3f8ef8/sugar/test/debug-meta-lang.rkt + +(require rackunit + (for-meta 1 (only-in racket/base begin-for-syntax)) + (for-meta 2 (only-in racket/base begin-for-syntax)) + (for-meta 3 (only-in racket/base let #%app open-output-string get-output-string parameterize + current-error-port #%datum) + rackunit)) + +(let ([out (open-output-string)] + [let "something else"] + [local-require "something else entirely"] + [only-in "completely unexpected!"] + [report "well, not really"]) + (parameterize ([current-error-port out]) + #R5) + (check-equal? (get-output-string out) "5 = 5\n")) + +(let ([out (open-output-string)] + [report/line "outta the blue!"]) + (parameterize ([current-error-port out]) + #RR5) + (check-equal? (get-output-string out) "5 = 5 on line 25\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 33\n"))))) diff --git a/info.rkt b/info.rkt index 37d03b4..cbd234e 100644 --- a/info.rkt +++ b/info.rkt @@ -6,3 +6,7 @@ '("base" )) +(define build-deps + '("rackunit-lib" + )) +