support more atomic rewriting

Author: pnwamk

redex-doc/redex/scribblings/ref/typesetting.scrbl

@@ -1048,18 +1048,18 @@ The @racket[proc] must match the contract @racket[(-> lw? lw?)].
 Its result should be the rewritten version version of the input.
 }
 
-@defform[(with-atomic-rewriter name-symbol
+@defform[(with-atomic-rewriter atom
                                string-or-thunk-returning-pict
                                expression)]{
 
 Extends the current set of atomic-rewriters with one
-new one that rewrites the value of name-symbol to
+new one that rewrites the value of atom to
 @racket[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 @racket[string-or-thunk-returning-pict] is used whenever the symbol
-appears in a pattern.
+@racket[atom] is expected to evaluate to a symbol, string, boolean,
+ or number. The value of @racket[string-or-thunk-returning-pict] is
+used that atom appears in a pattern.
 
 @ex[
   (define-language lam-lang
@@ -1071,7 +1071,7 @@ appears in a pattern.
 ]
 }
 
-@defform[(with-atomic-rewriters ([name-symbol string-or-thunk-returning-pict] ...)
+@defform[(with-atomic-rewriters ([atom string-or-thunk-returning-pict] ...)
                                   expression)]{
 Shorthand for nested @racket[with-atomic-rewriter] expressions.
 @history[#:added "1.4"]}

redex-pict-lib/redex/pict.rkt

@@ -167,7 +167,8 @@
 (provide with-unquote-rewriter
          with-compound-rewriter
          with-compound-rewriters
-         with-atomic-rewriter)
+         with-atomic-rewriter
+         with-atomic-rewriters)
 
 (provide/contract
  [set-arrow-pict! (-> symbol? (-> pict?) void?)]

redex-pict-lib/redex/private/core-layout.rkt

@@ -88,21 +88,39 @@
                    (basic-text "..." (default-style)))))
        (hole "[]"))))
 
+  ;; generate the assoc-table lookup entries to rewrite atoms
+  ;; (i.e. since internally all atom literals will be a string
+  ;;       of some sort)
+  (define (generate-atom-entries atom transformer)
+    (match atom
+      [(? symbol?) (list (list atom transformer))]
+      [(? string?) (list (list (format "“~a”" atom) transformer)
+                         (list (format "~v" atom) transformer))]
+      [#t (list (list "#t" transformer)
+                (list "#T" transformer)
+                (list "#true" transformer))]
+      [#f (list (list "#f" transformer)
+                (list "#F" transformer)
+                (list "#false" transformer))]
+      [(? number?) (list (list (number->string atom) transformer))]))
+
   (define-syntax-rule 
     (with-atomic-rewriter name rewriter body)
     (with-atomic-rewriters ([name rewriter]) body))
   (define-syntax (with-atomic-rewriters stx)
     (syntax-parse stx
       [(_ ([name transformer] ...) e:expr)
        #:declare name
-       (expr/c #'symbol?
+       (expr/c #'(or/c symbol? string? boolean? number?)
                #:name "atomic-rewriter name")
        #:declare transformer
        (expr/c #'(or/c (-> pict?) string?)
                #:name "atomic-rewriter rewrite")
        #`(parameterize ([atomic-rewrite-table
-                         (append (list (list name.c transformer.c) ...)
-                                 (atomic-rewrite-table))])
+                         (apply append
+                                (generate-atom-entries name.c transformer.c)
+                                 ...
+                                 (list (atomic-rewrite-table)))])
            e)]))
 
   ;; compound-rewrite-table : (listof lw) -> (listof (union lw pict string))
@@ -803,7 +821,8 @@
                 (string=? "#:" (substring atom 0 2))))
        (list (make-string-token col span atom (paren-style)))]
       [(string? atom)
-       (list (make-string-token col span atom (default-style)))]
+       (list (or (rewrite-atomic col span atom literal-style)
+                 (make-string-token col span atom (default-style))))]
       [else (error 'atom->tokens "unk ~s" atom)]))
 
   (define (rewrite-atomic col span e get-style)
@@ -818,7 +837,7 @@
     [(assoc e (atomic-rewrite-table))
      =>
      (λ (m)
-       (when (eq? (cadr m) e)
+       (when (equal? (cadr m) e)
          (error 'apply-rewrites "rewritten version of ~s is still ~s" e e))
        (let ([p (cadr m)])
          (if (procedure? p)