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

Changed rec-id black magic to a more robust syntax parameter solution.

Browse Source
This commit is contained in:
James Ian Johnson 2011-08-21 09:34:13 -04:00 committed by Sam Tobin-Hochstadt
parent a873675832
commit e12472bdf7
1 changed files with 30 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/typed-scheme/rep/rep-utils.rkt
View File

@ -8,8 +8,8 @@
"interning.rkt" "interning.rkt"
racket/syntax unstable/match unstable/struct racket/syntax unstable/match unstable/struct
mzlib/etc mzlib/etc
scheme/contract
racket/stxparam racket/stxparam
scheme/contract
(for-syntax (for-syntax
scheme/list scheme/list
(only-in racket/syntax generate-temporary) (only-in racket/syntax generate-temporary)
@ -259,9 +259,7 @@
#:when (no-duplicates? (attribute k.datum)) #:when (no-duplicates? (attribute k.datum))
#:attr mapping (for/hash ([k* (attribute k.datum)] #:attr mapping (for/hash ([k* (attribute k.datum)]
[e* (attribute e)]) [e* (attribute e)])
(values k* (if (identifier? e*) (values k* e*))))
(make-rename-transformer e*)
e*)))))
(syntax-parse stx (syntax-parse stx
[(tc (~var recs (sized-list kws)) ty clauses:clause ...) [(tc (~var recs (sized-list kws)) ty clauses:clause ...)
;; map defined types' keywords to their given fold-rhs's. ;; map defined types' keywords to their given fold-rhs's.
@ -270,26 +268,33 @@
(for ([k (attribute clauses.kw)] (for ([k (attribute clauses.kw)]
[v (attribute clauses.val)]) [v (attribute clauses.val)])
(hash-set! new-hashtable k v)) (hash-set! new-hashtable k v))
(with-syntax ([(parameterize-clauses ...) ;; bind given expressions for #:Type etc to local ids
(for/list ([rec-id rec-ids] (define rec-ids* (generate-temporaries rec-ids))
(with-syntax ([(let-clauses ...)
(for/list ([rec-id* rec-ids*]
[k kws]) [k kws])
;; Each rec-id binds to their corresponding given exprs ;; Each rec-id binds to their corresponding given exprs
;; rec-ids and kws correspond pointwise. ;; rec-ids and kws correspond pointwise.
#`[#,rec-id #,(hash-ref (attribute recs.mapping) k #`[#,rec-id* #,(hash-ref (attribute recs.mapping) k
#'values)])] #'values)])]
[(parameterize-clauses ...)
(for/list ([rec-id rec-ids]
[rec-id* rec-ids*])
#`[#,rec-id (make-rename-transformer #'#,rec-id*)])]
[(match-clauses ...) [(match-clauses ...)
;; create all clauses we fold on, with keyword/body ;; create all clauses we fold on, with keyword/body
(hash-map new-hashtable gen-clause)] (hash-map new-hashtable gen-clause)]
[error-msg (quasisyntax/loc stx (error 'tc "no pattern for ~a" #,fold-target))]) [error-msg (quasisyntax/loc stx (error 'tc "no pattern for ~a" #,fold-target))])
#`(syntax-parameterize (parameterize-clauses ...) #`(let (let-clauses ...
(let (;; binds #'fold-target to the given element to fold down. ;; binds #'fold-target to the given element to fold down.
;; e.g. In a type-case, this is commonly "ty." Others perhaps "e". ;; e.g. In a type-case, this is commonly "ty." Others perhaps "e".
[#,fold-target ty]) [#,fold-target ty])
;; then generate the fold (syntax-parameterize (parameterize-clauses ...)
#,(quasisyntax/loc stx ;; then generate the fold
(match #,fold-target #,(quasisyntax/loc stx
match-clauses ... (match #,fold-target
[_ error-msg])))))]))) match-clauses ...
[_ error-msg])))))])))
(define-syntax (make-prim-type stx) (define-syntax (make-prim-type stx)
@ -319,19 +324,20 @@
i.pred? ... i.pred? ...
i.rec-id ... i.rec-id ...
i.accessors ... ... ;; several accessors per type. i.accessors ... ... ;; several accessors per type.
(for-syntax i.hashtable ...)) (for-syntax i.hashtable ... ))
;; make type name and populate hashtable with ;; make type name and populate hashtable with
;; keyword to (list match-expander-stx fields fold-rhs.proc #f) ;; keyword to (list match-expander-stx fields fold-rhs.proc #f)
;; e.g. def-type type-name-ht #t ;; e.g. def-type type-name-ht #t
(define-syntax i.define-id (mk #'i.name #'i.hashtable i.key? #'i.rec-id)) ... (define-syntax i.define-id
(mk #'i.name #'i.hashtable i.key? #'i.rec-id)) ...
(define-for-syntax i.hashtable (make-hasheq)) ... (define-for-syntax i.hashtable (make-hasheq)) ...
(define-struct/printer (i.name Rep) (i.field-names ...) (define-struct/printer (i.name Rep) (i.field-names ...)
(lambda (a b c) ((unbox i.printer) a b c))) ... (lambda (a b c) ((unbox i.printer) a b c))) ...
(define-syntax-parameter i.rec-id (define-syntax-parameter i.rec-id
(λ (stx) (λ (stx)
(raise-syntax-error #f (raise-syntax-error #f
(format "used outside ~a" 'i.define-id) (format "used outside ~a" 'i.define-id)
stx))) ... stx))) ...
(provide i.case ...) (provide i.case ...)
(define-syntaxes (i.case ...) ;; each fold case gets its own macro. (define-syntaxes (i.case ...) ;; each fold case gets its own macro.
(let ([rec-ids (list #'i.rec-id ...)]) (let ([rec-ids (list #'i.rec-id ...)])
@ -341,6 +347,7 @@
;; [unsyntax (*1)] ;; [unsyntax (*1)]
(mk-fold ht (mk-fold ht
rec-ids rec-ids
;; '(#:Type #:Filter #:Object #:PathElem)
'(i.kw ...))) '(i.kw ...)))
(list i.hashtable ...))))))])) (list i.hashtable ...))))))]))