From 08dcc922d99cd12faa87c3a366e02907472c85bc Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sat, 11 Jun 2016 21:53:22 -0700
Subject: [PATCH] `begin-label`

---
 beautiful-racket-lib/br/begin-label.rkt | 27 --------
 beautiful-racket-lib/br/syntax.rkt      | 23 ++++++-
 beautiful-racket-lib/br/to-string.rkt   | 92 +++++++++++++++++++++++++
 3 files changed, 113 insertions(+), 29 deletions(-)
 delete mode 100644 beautiful-racket-lib/br/begin-label.rkt
 create mode 100644 beautiful-racket-lib/br/to-string.rkt

diff --git a/beautiful-racket-lib/br/begin-label.rkt b/beautiful-racket-lib/br/begin-label.rkt
deleted file mode 100644
index 883247b..0000000
--- a/beautiful-racket-lib/br/begin-label.rkt
+++ /dev/null
@@ -1,27 +0,0 @@
-#lang br
-(require rackunit)
-(provide (all-defined-out))
-
-(define (syntax->source stx)
-  ;; reconstitute the source string by using srclocs
-  ;; magic goes here
-    stx)
-
-(define-macro (begin-label LABEL . EXPRS)
-  #'(begin
-      (define LABEL (syntax->source #'EXPRS))
-      (provide LABEL)
-      (begin . EXPRS)))
-
-(begin-label
-  zing
-  (define (f x)
-    (+ x x))
-  
-  (define (g x)
-    (* x x)))
-
-(display zing)
-
-(check-equal? (f 5) 10)
-#;(check-equal? (g 5) 25)
\ No newline at end of file
diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt
index e4917bb..73ca511 100644
--- a/beautiful-racket-lib/br/syntax.rkt
+++ b/beautiful-racket-lib/br/syntax.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 (require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context)
-         syntax/strip-context racket/function racket/list racket/syntax)
+         syntax/strip-context racket/function racket/list racket/syntax br/to-string)
 (provide (all-defined-out) (all-from-out syntax/strip-context))
 
 (module+ test
@@ -141,4 +141,23 @@
      (define maybe-list (syntax->list stx))
      (if maybe-list
          (map loop maybe-list)
-         stx))))
\ No newline at end of file
+         stx))))
+
+(define-syntax-rule (begin-label LABEL . EXPRS)
+  (begin
+    (define LABEL (syntax->string #'EXPRS))
+    (provide LABEL)
+    (begin . EXPRS)))
+
+(module+ test
+  (begin-label
+    zing
+    (define (f x)
+      [+ x x])
+    
+    (define (g x)
+      (* x x)))
+  
+  (check-equal? zing "(define (f x)\n  [+ x x])\n\n(define (g x)\n  (* x x))")
+  (check-equal? (f 5) 10)
+  (check-equal? (g 5) 25))
\ No newline at end of file
diff --git a/beautiful-racket-lib/br/to-string.rkt b/beautiful-racket-lib/br/to-string.rkt
new file mode 100644
index 0000000..ec3e840
--- /dev/null
+++ b/beautiful-racket-lib/br/to-string.rkt
@@ -0,0 +1,92 @@
+#lang racket/base
+(require racket/contract/base
+         syntax/stx)
+
+(require racket/list)
+
+(define (syntax->string c)
+  (let* ([s (open-output-string)]
+         [l (syntax->list c)]
+         [init-col (or (syntax-column (first l)) 0)]
+         [col init-col]
+         [line (or (syntax-line (first l)) 0)])
+    (define (advance c init-line!)
+      (let ([c (syntax-column c)]
+            [l (syntax-line c)])
+        (when (and l (l . > . line))
+          (for-each (λ (_) (newline)) (range (- l line)))
+          (set! line l)
+          (init-line!))
+        (when c
+          (display (make-string (max 0 (- c col)) #\space))
+          (set! col c))))
+    (parameterize ([current-output-port s]
+                   [read-case-sensitive #t])
+      (define (loop init-line!)
+        (lambda (c)
+          (cond
+            [(eq? 'code:blank (syntax-e c))
+             (advance c init-line!)]
+            [(eq? '_ (syntax-e c)) (void)]
+            [(eq? '... (syntax-e c))
+             (void)]
+            [(and (pair? (syntax-e c))
+                  (eq? (syntax-e (car (syntax-e c))) 'code:comment))
+             (advance c init-line!)
+             (printf "; ")
+             (display (syntax-e (cadr (syntax->list c))))]
+            [(and (pair? (syntax-e c))
+                  (eq? (syntax-e (car (syntax-e c))) 'code:contract))
+             (advance c init-line!)
+             (printf "; ")
+             (let* ([l (cdr (syntax->list c))]
+                    [s-col (or (syntax-column (first l)) col)])
+               (set! col s-col)
+               (for-each (loop (lambda ()
+                                 (set! col s-col)
+                                 (printf "; ")))
+                         l))]
+            [(and (pair? (syntax-e c))
+                  (eq? (syntax-e (car (syntax-e c))) 'quote))
+             (advance c init-line!)
+             (printf "'")
+             (let ([i (cadr (syntax->list c))])
+               (set! col (or (syntax-column i) col))
+               ((loop init-line!) i))]
+            [(pair? (syntax-e c))
+             (advance c init-line!)
+             (define c-paren-shape (syntax-property c 'paren-shape))
+             (printf (format "~a" (or c-paren-shape #\()))
+             (set! col (+ col 1))
+             (map (loop init-line!) (syntax->list c))
+             (printf (case c-paren-shape
+                       [(#\[) "]"]
+                       [(#\{) "}"]
+                       [else ")"]))
+             (set! col (+ col 1))]
+            [(vector? (syntax-e c))
+             (advance c init-line!)
+             (printf "#(")
+             (set! col (+ col 2))
+             (map (loop init-line!) (vector->list (syntax-e c)))
+             (printf ")")
+             (set! col (+ col 1))]
+            [else
+             (advance c init-line!)
+             (let ([s (format "~s" (syntax-e c))])
+               (set! col (+ col (string-length s)))
+               (display s))])))
+      (for-each (loop (lambda () (set! col init-col))) l))
+    (get-output-string s)))
+
+(provide/contract [syntax->string (-> (and/c syntax? stx-list?)
+                                      string?)])
+
+(module+ test
+  (require rackunit)
+  (check-equal? (syntax->string
+                #'((define (f x)
+                     [+ x x])
+                   
+                   (define (g x)
+                     (* x x)))) "(define (f x)\n  [+ x x])\n\n(define (g x)\n  (* x x))"))