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

Fix define-typed-struct/exec to pass struct-info.

Browse Source 
original commit: ee4ba2e3dd18d875a7e7fb6a3a00d9fe9b222ea2
This commit is contained in:
Sam Tobin-Hochstadt 2012-09-27 17:08:49 -04:00
parent 0f2cffde42
commit bb2afd9169
1 changed files with 30 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/typed-racket/base-env/prims.rkt
View File

@ -416,17 +416,6 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ (tname:id args:id ...) rest)
(syntax/loc stx (define-type-alias tname (All (args ...) rest)))]))
(define-syntax (define-typed-struct/exec stx)
(syntax-parse stx #:literals (:)
[(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
(with-syntax*
([proc* (syntax-property #'(ann proc : proc-ty) 'typechecker:with-type #t)]
[d-s (syntax-property (syntax/loc stx (define-struct nm (fld.name ...)
#:property prop:procedure proc*))
'typechecker:ignore-some #t)]
[dtsi (internal (syntax/loc stx (define-typed-struct/exec-internal nm (fld ...) proc-ty)))])
#'(begin d-s dtsi))]))
(define-syntax (with-handlers: stx)
(syntax-parse stx
[(_ ([pred? action] ...) . body)
@ -439,7 +428,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typechecker:with-handlers
#t))]))
(define-syntax (dtsi* stx)
(begin-for-syntax
(define-syntax-class struct-name
#:description "struct name (with optional super-struct name)"
#:attributes (name super value)
@ -447,17 +436,36 @@ This file defines two sorts of primitives. All of them are provided into any mod
#:attr value (attribute name.value))
(pattern (~var name (static struct-info? "struct name"))
#:attr value (attribute name.value)
#:with super #f))
(syntax-parse stx
[(_ () nm:struct-name . rest)
(internal (quasisyntax/loc stx
(define-typed-struct-internal
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]
[(_ (vars:id ...) nm:struct-name . rest)
(internal (quasisyntax/loc stx
(define-typed-struct-internal (vars ...)
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]))
#:with super #f)))
(define-syntax (define-typed-struct/exec stx)
(syntax-parse stx #:literals (:)
[(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
(with-syntax*
([proc* (syntax-property #'(ann proc : proc-ty) 'typechecker:with-type #t)]
[d-s (syntax-property (syntax/loc stx (define-struct nm (fld.name ...)
#:property prop:procedure proc*))
'typechecker:ignore-some #t)]
[dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))])
#'(begin d-s dtsi))]))
(define-syntaxes (dtsi* dtsi/exec*)
(let ()
(define (mk internal-id)
(lambda (stx)
(syntax-parse stx
[(_ () nm:struct-name . rest)
(internal (quasisyntax/loc stx
(#,internal-id
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]
[(_ (vars:id ...) nm:struct-name . rest)
(internal (quasisyntax/loc stx
(#,internal-id (vars ...)
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))])))
(values (mk #'define-typed-struct-internal)
(mk #'define-typed-struct/exec-internal))))
(define-syntaxes (define-typed-struct struct:)
(let ()
(define-syntax-class fld-spec