diff --git a/redex-doc/redex/scribblings/ref/typesetting.scrbl b/redex-doc/redex/scribblings/ref/typesetting.scrbl index 8f197713..a7c6df58 100644 --- a/redex-doc/redex/scribblings/ref/typesetting.scrbl +++ b/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"]} diff --git a/redex-pict-lib/redex/pict.rkt b/redex-pict-lib/redex/pict.rkt index fa8ff478..46189678 100644 --- a/redex-pict-lib/redex/pict.rkt +++ b/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?)] diff --git a/redex-pict-lib/redex/private/core-layout.rkt b/redex-pict-lib/redex/private/core-layout.rkt index d1615e4b..c200e38f 100644 --- a/redex-pict-lib/redex/private/core-layout.rkt +++ b/redex-pict-lib/redex/private/core-layout.rkt @@ -88,6 +88,22 @@ (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)) @@ -95,14 +111,16 @@ (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)