dev-refac-2020
Matthew Butterick 7 years ago
parent db5bbb9a40
commit f79077aec9

@ -84,72 +84,44 @@
[debug-read-syntax read-syntax] [debug-read-syntax read-syntax]
[debug-get-info get-info])) [debug-get-info get-info]))
(define report-char #\R) (define current-metalang-scope-flipper (make-parameter values))
(define (make-debug-readtable [rt (current-readtable)])
(make-readtable rt report-char 'dispatch-macro report-proc))
(define (wrap-reader reader) (define (wrap-reader reader)
(define (rd . args) (λ args
(define intro (make-syntax-introducer))
(parameterize ([current-readtable (make-debug-readtable (current-readtable))] (parameterize ([current-readtable (make-debug-readtable (current-readtable))]
[current-syntax-introducer intro]) [current-metalang-scope-flipper (make-syntax-introducer)])
(define stx (apply reader args)) (define stx (apply reader args))
(if (and (syntax? stx) (version<=? "6.2.900.4" (version))) (define proc (if (and (syntax? stx) (version<=? "6.2.900.4" (version)))
(intro stx) (current-metalang-scope-flipper)
stx))) values))
rd) (proc stx))))
(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 sugar/debug [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 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) (define-values (debug-read debug-read-syntax debug-get-info)
(make-meta-reader (make-meta-reader
'sugar/debug 'sugar/debug
"language path" "language path"
(lambda (bstr) lang-reader-module-paths
(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
wrap-reader wrap-reader
(lambda (proc) (λ (proc)
(lambda (key defval) (λ (key defval)
(define (fallback) (if proc (proc key defval) defval))
(case key (case key
[else (fallback)])))))) [else (if proc (proc key defval) defval)])))))
(define report-char #\R)
(define (make-debug-readtable [rt (current-readtable)])
(make-readtable rt report-char 'dispatch-macro report-proc))
(define (another-report-char? ip) (and (char=? (peek-char ip) report-char) (read-char ip)))
(define (report-proc trigger-char ip src ln col pos)
(define flip-metalang-scope (current-metalang-scope-flipper))
(flip-metalang-scope (with-syntax ([REPORT-ID (cond
[(not (another-report-char? ip)) 'report] ; #R...
[(not (another-report-char? ip)) 'report/line] ; #RR...
[else 'report/file])] ; #RRR...
[STX (flip-metalang-scope (read-syntax/recursive src ip))])
#'(let ()
(local-require (only-in sugar/debug REPORT-ID))
(REPORT-ID STX))))))

Loading…
Cancel
Save