add syntactic shorthand for `report`

pull/8/head
Matthew Butterick 9 years ago
parent ecce73cdc3
commit 0ffe317387

@ -5,3 +5,80 @@
(provide+safe report report/line report/file (provide+safe report report/line report/file
report* report*/line report*/file report* report*/line report*/file
report-apply repeat time-repeat time-repeat* compare) 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)]))))))

@ -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)]))))))

@ -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)

@ -1,4 +1,4 @@
#lang sugar/debug/lang racket #lang sugar/debug racket
(require rackunit) (require rackunit)
(let ([out (open-output-string)] (let ([out (open-output-string)]
[let "something else"] [let "something else"]
@ -6,10 +6,10 @@
[only-in "completely unexpected!"] [only-in "completely unexpected!"]
[report "well, not really"]) [report "well, not really"])
(parameterize ([current-error-port out]) (parameterize ([current-error-port out])
#^5) ^5)
(check-equal? (get-output-string out) "5 = 5\n")) (check-equal? (get-output-string out) "5 = 5\n"))
(let ([out (open-output-string)] (let ([out (open-output-string)]
[report/line "outta the blue!"]) [report/line "outta the blue!"])
(parameterize ([current-error-port out]) (parameterize ([current-error-port out])
#^^5) ^^5)
(check-equal? (get-output-string out) "5 = 5 on line 14\n")) (check-equal? (get-output-string out) "5 = 5 on line 14\n"))

@ -29,7 +29,7 @@
(with-syntax ([file (syntax-source #'expr)] (with-syntax ([file (syntax-source #'expr)]
[line (syntax-line #'expr)]) [line (syntax-line #'expr)])
#'(let ([expr-result 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))])) expr-result))]))

Loading…
Cancel
Save