add contracts to the "with-" macros in redex/pict

collects/redex/private/core-layout.rkt

@@ -11,8 +11,10 @@
          racket/match
          racket/draw
          racket/class
+         racket/contract 
          
-         (for-syntax racket/base))
+         (for-syntax racket/base
+                     syntax/parse))
 
 (define pink-code-font 'modern)
 
@@ -68,10 +70,16 @@
        (hole "[]"))))
   
   (define-syntax (with-atomic-rewriter stx)
-    (syntax-case stx ()
+    (syntax-parse stx
-      [(_ name transformer e)
+      [(_ name transformer e:expr)
+       #:declare name
+       (expr/c #'symbol?
+               #:name "atomic-rewriter name")
+       #:declare transformer
+       (expr/c #'(or/c (-> pict?) string?)
+               #:name "atomic-rewriter rewrite")
        #'(parameterize ([atomic-rewrite-table
-                         (cons (list name transformer)
+                         (cons (list name.c transformer.c)
                                (atomic-rewrite-table))])
            e)]))
   
@@ -102,24 +110,31 @@
                         the-name
                         (blank))))))))
   
-  (define-syntax-rule (with-compound-rewriter name rewriter body)
+  (define-syntax-rule 
+    (with-compound-rewriter name rewriter body)
     (with-compound-rewriters ([name rewriter]) body))
-  (define-syntax with-compound-rewriters
+  (define-syntax (with-compound-rewriters stx)
-    (syntax-rules ()
+    (syntax-parse stx
-      [(_ ([name rewriter] ...) body)
+      [(_ ([name rewriter] ...) body:expr)
-       (parameterize ([compound-rewrite-table
+       #:declare name (expr/c #'symbol? #:name "compound-rewriter name")
-                       (append (reverse (list (list name rewriter) ...))
+       #:declare rewriter (expr/c #'(-> (listof lw?)
-                               (compound-rewrite-table))])
+                                        (listof (or/c lw? string? pict?)))
-         body)]))
+                                  #:name "compound-rewriter transformer")
+       #'(parameterize ([compound-rewrite-table
+                         (append (reverse (list (list name rewriter.c) ...))
+                                 (compound-rewrite-table))])
+           body)]))
+  
   
   (define-syntax (with-unquote-rewriter stx)
-    (syntax-case stx ()
+    (syntax-parse stx
-      [(_ transformer e)
+      [(_ transformer e:expr)
-       #'(parameterize ([current-unquote-rewriter transformer])
+       #:declare transformer
+       (expr/c #'(-> lw? lw?)
+               #:name "unquote-rewriter")
+       #'(parameterize ([current-unquote-rewriter transformer.c])
            e)]))
   (define current-unquote-rewriter (make-parameter values))
-                                    
-  
   
   ;; token = string-token | spacer-token | pict-token | align-token | up-token
   

collects/redex/scribblings/ref.scrbl

@@ -2927,14 +2927,12 @@ To replace the pink code, use:
 
 @defform[(with-unquote-rewriter proc expression)]{
 
-It installs @racket[proc] the current unqoute rewriter and
+Installs @racket[proc] as the current unquote rewriter and
-evaluates expression. If that expression computes any picts,
+evaluates @racket[expression]. If that expression computes any picts,
 the unquote rewriter specified is used to remap them.
 
-The @racket[proc] should be a function of one argument. It receives
+The @racket[proc] must match the contract @racket[(-> lw? lw?)].
-a @racket[lw] struct as an argument and should return
+Its result should be the rewritten version version of the input.
-another @racket[lw] that contains a rewritten version of the
-code.
 }
 
 @defform[(with-atomic-rewriter name-symbol
@@ -2947,7 +2945,7 @@ string-or-pict-returning-thunk (applied, in the case of a
 thunk), during the evaluation of expression.
 
 @racket[name-symbol] is expected to evaluate to a symbol. The value
-of string-or-thunk-returning-pict is used whever the symbol
+of string-or-thunk-returning-pict is used whenever the symbol
 appears in a pattern.
 }
 

collects/redex/tests/bitmap-test.rkt

@@ -243,8 +243,11 @@
         (list-ref lws 4)
         "}"))
 
-(btest (with-compound-rewriter 'subst subst-rw
+(btest (with-atomic-rewriter
-                               (render-metafunction subst))
+        'number "number" ;; this rewriter has no effect; here to test that path in the code
+        (with-compound-rewriter
+         'subst subst-rw
+         (render-metafunction subst)))
        "metafunction-subst.png")