suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/strip-context: handle hash tables

Browse Source 
Closes racket/scribble#245
This commit is contained in:
Matthew Flatt 2020-07-02 14:42:18 -06:00
parent d50d74e458
commit e0f390c8c8
3 changed files with 64 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-doc/syntax/scribblings/strip-context.scrbl
View File

@ -8,10 +8,15 @@
@defproc[(strip-context [stx syntax?]) syntax?]{
Removes all lexical context from @racket[stx], preserving
source-location information and properties.}
source-location information and properties.
@history[#:changed "7.7.0.10" @elem{Repaired to traverse hash tables in @racket[stx].}]}
@defproc[(replace-context [ctx-stx (or/c syntax? #f)] [stx syntax?]) syntax?]{
Uses the lexical context of @racket[ctx-stx] to replace the lexical
context of all parts of @racket[stx], preserving source-location
information and properties of @racket[stx].}
information and properties of @racket[stx].
@history[#:changed "7.7.0.10" @elem{Repaired to traverse hash tables in @racket[stx].}]}

43
pkgs/racket-test-core/tests/racket/syntax.rktl
View File

@ -2173,6 +2173,49 @@
(list #'define-syntax1)
(syntax-property expanded-body-stx 'origin)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure that `strip-context` works on prefabs, hash tables, etc.
(let ()
(define (same? a b)
(cond
[(syntax? a)
(and (syntax? b)
(equal? (for/hash ([k (in-list (hash-ref (syntax-debug-info a) 'context))])
(values k #t))
(for/hash ([k (in-list (hash-ref (syntax-debug-info b) 'context))])
(values k #t)))
(same? (syntax-e a) (syntax-e b)))]
[(pair? a) (and (pair? b)
(same? (car a) (car b))
(same? (cdr a) (cdr b)))]
[(box? a) (and (box? b)
(same? (unbox a) (unbox b)))]
[(vector? a) (and (vector? b)
(= (vector-length a) (vector-length b))
(for/and ([a (in-vector a)]
[b (in-vector b)])
(same? a b)))]
[(hash? a) (and (eq? (hash-eq? a) (hash-eq? b))
(eq? (hash-eqv? a) (hash-eqv? b))
(eq? (hash-equal? a) (hash-equal? b))
(for/and ([(ak av) (in-hash a)])
(same? av (hash-ref b ak #f))))]
[(prefab-struct-key a)
=> (lambda (ak)
(and (equal? ak (prefab-struct-key b))
(same? (struct->vector a) (struct->vector b))))]
[else (eqv? a b)]))
(define (check v)
(same? (datum->syntax #f v)
(strip-context (datum->syntax #'here v))))
(test #t check '(a b))
(test #t check '#(a b #hash((c . 9))))
(test #t check '(#hasheqv((10 . 11) (12 . 13)) #&"str" #s(color r G #b0)))
(test #t check '(#hasheq((x . 11) (y . 13) (z . #f)) (1 . 2))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module tries-to-use-foo-before-defined racket/base

14
racket/collects/syntax/strip-context.rkt
View File

@ -25,4 +25,18 @@
(apply make-prefab-struct
k
(replace-context ctx (struct->list e))))]
[(hash? e)
(cond
[(hash-eq? e)
(for/hasheq ([(k v) (in-hash e)])
(values (replace-context ctx k)
(replace-context ctx v)))]
[(hash-eqv? e)
(for/hasheqv ([(k v) (in-hash e)])
(values (replace-context ctx k)
(replace-context ctx v)))]
[else
(for/hash ([(k v) (in-hash e)])
(values (replace-context ctx k)
(replace-context ctx v)))])]
[else e]))