From 75912ccbd6975ed8fae8ac13a52bc72c6ca4e9e1 Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Sat, 4 Jul 2015 18:44:08 -0400
Subject: [PATCH] add sugar/debug/lang meta-language

---
 sugar/debug.rkt                  |  4 +++-
 sugar/debug/lang/lang/reader.rkt | 28 ++++++++++++++++++++++++++++
 sugar/debug/reader.rkt           | 30 ++++++++++++++++++++++++++++++
 sugar/test/debug-meta-lang.rkt   | 10 ++++++++++
 4 files changed, 71 insertions(+), 1 deletion(-)
 create mode 100644 sugar/debug/lang/lang/reader.rkt
 create mode 100644 sugar/debug/reader.rkt
 create mode 100644 sugar/test/debug-meta-lang.rkt

diff --git a/sugar/debug.rkt b/sugar/debug.rkt
index 9e5ac12..42778c9 100644
--- a/sugar/debug.rkt
+++ b/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)
\ No newline at end of file
+(provide+safe report report/line report/file
+              report* report*/line report*/file
+              report-apply repeat time-repeat time-repeat* compare)
diff --git a/sugar/debug/lang/lang/reader.rkt b/sugar/debug/lang/lang/reader.rkt
new file mode 100644
index 0000000..60fe625
--- /dev/null
+++ b/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)]))))))
diff --git a/sugar/debug/reader.rkt b/sugar/debug/reader.rkt
new file mode 100644
index 0000000..4e0f70e
--- /dev/null
+++ b/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)
+
diff --git a/sugar/test/debug-meta-lang.rkt b/sugar/test/debug-meta-lang.rkt
new file mode 100644
index 0000000..833039f
--- /dev/null
+++ b/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"))