Merge pull request #5 from AlexKnauth/debug-meta-lang

add sugar/debug/lang meta-language

sugar/debug.rkt

@@ -2,4 +2,6 @@
 (require sugar/define)
 (require-via-wormhole "../typed/sugar/debug.rkt")
 
-(provide+safe report report-apply report* repeat time-repeat time-repeat* compare)
+(provide+safe report report/line report/file
+              report* report*/line report*/file
+              report-apply repeat time-repeat time-repeat* compare)

sugar/debug/lang/lang/reader.rkt

@@ -0,0 +1,28 @@
+(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)]))))))

sugar/debug/reader.rkt

@@ -0,0 +1,30 @@
+#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/with-syntax report (datum->syntax #f 'report))
+(define/with-syntax report/line (datum->syntax #f 'report/line))
+
+(define (report-proc c in src ln col pos)
+  (define c2 (peek-char in))
+  (cond [(char=? c2 #\^)
+         (read-char in)
+         (define stx (read-syntax/recursive src in))
+         #`(report/line #,stx)]
+        [else
+         (define stx (read-syntax/recursive src in))
+         #`(report #,stx)]))
+
+(define (wrap-reader reader)
+  (define (rd . args)
+    (parameterize ([current-readtable (make-debug-readtable (current-readtable))])
+      (apply reader args)))
+  rd)
+

sugar/test/debug-meta-lang.rkt

@@ -0,0 +1,10 @@
+#lang sugar/debug/lang racket
+(require sugar/debug rackunit)
+(let ([out (open-output-string)])
+  (parameterize ([current-error-port out])
+    #^5)
+  (check-equal? (get-output-string out) "5 = 5\n"))
+(let ([out (open-output-string)])
+  (parameterize ([current-error-port out])
+    #^^5)
+  (check-equal? (get-output-string out) "5 = 5 on line 9\n"))