From b43e956c7b5d747cbb8f953c78c1641fa2aa9b93 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 30 May 2011 08:10:20 -0500
Subject: [PATCH] Redex: added to-lw/stx  plus improved the redex docs slightly
 and Rackety

---
 collects/redex/pict.rkt                   | 28 +++++++++++++++++++++--
 collects/redex/private/loc-wrapper-ct.rkt |  3 ++-
 collects/redex/redex.scrbl                | 10 +++++++-
 collects/redex/tests/lw-test.rkt          |  8 +++++--
 4 files changed, 43 insertions(+), 6 deletions(-)

diff --git a/collects/redex/pict.rkt b/collects/redex/pict.rkt
index 340096693c..027f8429f3 100644
--- a/collects/redex/pict.rkt
+++ b/collects/redex/pict.rkt
@@ -1,6 +1,6 @@
-#lang scheme/base
+#lang racket/base
 
-(require scheme/contract
+(require racket/contract
          "private/pict.ss"
          "private/core-layout.ss"
          "private/loc-wrapper.ss"
@@ -108,8 +108,32 @@
  lw-column-span)
 
 (provide to-lw
+         to-lw/stx
          (struct-out lw))
 
+(require (prefix-in lw/ct: "private/loc-wrapper-ct.rkt")
+         (prefix-in lw/rt: "private/loc-wrapper-rt.rkt"))
+(define (to-lw/stx stx)
+  (let loop ([stx (lw/ct:to-lw/proc stx)])
+    (syntax-case stx (init-loc-wrapper make-lw add-spans list quote)
+      [(make-lw arg ...) 
+       (apply make-lw (map loop (syntax->list #'(arg ...))))]
+      [(init-loc-wrapper arg ...)
+       (apply lw/rt:init-loc-wrapper (map loop (syntax->list #'(arg ...))))]
+      [(add-spans arg ...)
+       (apply lw/rt:add-spans (map loop (syntax->list #'(arg ...))))]
+      [(list arg ...)
+       (apply list (map loop (syntax->list #'(arg ...))))]
+      [(quote arg)
+       (syntax->datum #'arg)]
+      [_ 
+       (let ([x (syntax-e stx)])
+         (unless (or (number? x)
+                     (string? x)
+                     (boolean? x))
+           (error 'to-lw/stx "unk thing: ~s\n" (syntax->datum stx)))
+         x)])))
+
 (provide/contract
  [just-before (-> (or/c pict? string? symbol?) lw? lw?)]
  [just-after (-> (or/c pict? string? symbol?) lw? lw?)])
diff --git a/collects/redex/private/loc-wrapper-ct.rkt b/collects/redex/private/loc-wrapper-ct.rkt
index 1f2c301250..51f28aae05 100644
--- a/collects/redex/private/loc-wrapper-ct.rkt
+++ b/collects/redex/private/loc-wrapper-ct.rkt
@@ -67,7 +67,8 @@
         #,quoted?)]
     [x 
      (and (identifier? #'x)
-          (or (term-fn? (syntax-local-value #'x (λ () #f)))
+          (or (and (syntax-transforming?)
+                   (term-fn? (syntax-local-value #'x (λ () #f))))
               ((is-term-fn?) #'x)))
      #`(make-lw
         '#,(syntax-e #'x)
diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl
index be05030e87..d594818630 100644
--- a/collects/redex/redex.scrbl
+++ b/collects/redex/redex.scrbl
@@ -339,7 +339,8 @@ bound to @racket['()].
 If @racket[redex-match] receives three arguments, it
 matches the pattern (in the language) against its third
 argument. If it matches, this returns a list of match
-structures describing the matches. If it fails, it returns
+structures describing the matches (see @racket[match?] and 
+@racket[match-bindings]). If it fails, it returns
 @racket[#f].
 
 If @racket[redex-match] receives only two arguments, it
@@ -2589,6 +2590,13 @@ the empty string and the @racket[x] in the typeset output.
 
 }
 
+@defproc[(to-lw/stx [stx syntax?]) lw?]{
+  This is the runtime variant on @racket[to-lw]; it accepts a 
+  syntax object and returns the corresponding @racket[lw] structs.
+  It only uses the location information in the syntax object,
+  so metafunctions will not be rendered properly.
+}
+
 @defproc[(render-lw (language/nts (or/c (listof symbol?) compiled-lang?))
                     (lw lw?)) pict?]{
 
diff --git a/collects/redex/tests/lw-test.rkt b/collects/redex/tests/lw-test.rkt
index 869d72cfd0..a5532fd6ea 100644
--- a/collects/redex/tests/lw-test.rkt
+++ b/collects/redex/tests/lw-test.rkt
@@ -49,10 +49,11 @@
 ;                                                                 
 
 
-(module lw-test mzscheme
+(module lw-test racket/base
   (require "test-util.ss"
            "../private/loc-wrapper.ss"
-           "lw-test-util.ss")
+           "lw-test-util.ss"
+           (only-in "../pict.rkt" to-lw/stx))
   
   (reset-count)
   
@@ -286,5 +287,8 @@
            #t #f))
          0 0 0 3))
   
+  (test (normalize-lw (to-lw (a ((b)) c 1 #t)))
+        (normalize-lw (to-lw/stx #'(a ((b)) c 1 #t))))
+  
   (print-tests-passed "lw-test.ss"))