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

Clean up struct: and disallow unsupported options

Browse Source 
Related to PR 13562
This commit is contained in:
Asumu Takikawa 2013-05-02 18:24:55 -04:00
parent ccf1119b68
commit c3b80bee41
2 changed files with 83 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/tests/typed-racket/fail/pr13562.rkt Normal file
View File

@ -0,0 +1,8 @@
#;
(exn-pred #rx"struct:: expected the literal")
#lang typed/racket
;; Check that #:methods is ruled out
(struct: foo ([a : Integer]) #:methods gen:dict [])

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

@ -474,7 +474,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#t))])) #t))]))
(begin-for-syntax (begin-for-syntax
(define-syntax-class struct-name (define-syntax-class dtsi-struct-name
#:description "struct name (with optional super-struct name)" #:description "struct name (with optional super-struct name)"
#:attributes (name super value) #:attributes (name super value)
(pattern ((~var name (static struct-info? "struct name")) super:id) (pattern ((~var name (static struct-info? "struct name")) super:id)
@ -499,69 +499,90 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define (mk internal-id) (define (mk internal-id)
(lambda (stx) (lambda (stx)
(syntax-parse stx (syntax-parse stx
[(_ () nm:struct-name . rest) [(_ () nm:dtsi-struct-name . rest)
(internal (quasisyntax/loc stx (internal (quasisyntax/loc stx
(#,internal-id (#,internal-id
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))] #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]
[(_ (vars:id ...) nm:struct-name . rest) [(_ (vars:id ...) nm:dtsi-struct-name . rest)
(internal (quasisyntax/loc stx (internal (quasisyntax/loc stx
(#,internal-id (vars ...) (#,internal-id (vars ...)
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]))) #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))])))
(values (mk #'define-typed-struct-internal) (values (mk #'define-typed-struct-internal)
(mk #'define-typed-struct/exec-internal)))) (mk #'define-typed-struct/exec-internal))))
;; Syntax classes and helpers for `struct:`
(begin-for-syntax
(define-syntax-class fld-spec
#:literals (:)
#:description "[field-name : type]"
(pattern [fld:id : ty]))
(define-syntax-class struct-name
#:description "struct name (with optional super-struct name)"
#:attributes (name super)
(pattern (name:id super:id))
(pattern name:id
#:with super #f))
(define-splicing-syntax-class struct-name/new
#:description "struct name (with optional super-struct name)"
(pattern (~seq name:id super:id)
#:attr old-spec #'(name super)
#:with new-spec #'(name super))
(pattern name:id
#:with super #f
#:attr old-spec #'name
#:with new-spec #'(name)))
(define-splicing-syntax-class maybe-type-vars
#:description "optional list of type variables"
#:attributes ((vars 1))
(pattern (vars:id ...))
(pattern (~seq) #:attr (vars 1) null))
(define-splicing-syntax-class struct-options
#:description "typed structure type options"
#:attributes (guard mutable? transparent? [prop 1] [prop-val 1])
(pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?)))
(~optional (~seq (~and #:transparent transparent?)))
;; FIXME: unsound, but relied on in core libraries
;; #:guard ought to be supportable with some work
;; #:property is harder
(~optional (~seq #:guard guard:expr))
(~seq #:property prop:expr prop-val:expr))
...))))
;; User-facing macros for defining typed structure types
(define-syntaxes (define-typed-struct struct:) (define-syntaxes (define-typed-struct struct:)
(let () (values
(define-syntax-class fld-spec (lambda (stx)
#:literals (:) (syntax-parse stx
#:description "[field-name : type]" [(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...)
(pattern [fld:id : ty])) opts:struct-options)
(define-syntax-class struct-name (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())])
#:description "struct name (with optional super-struct name)" (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
#:attributes (name super) 'typechecker:ignore #t)]
(pattern (name:id super:id)) [dtsi (quasisyntax/loc stx
(pattern name:id (dtsi* (vars.vars ...) nm (fs ...)
#:with super #f)) #,@mutable?))])
(define-splicing-syntax-class struct-name/new #'(begin d-s dtsi)))]))
#:description "struct name (with optional super-struct name)" (lambda (stx)
(pattern (~seq name:id super:id) (syntax-parse stx
#:attr old-spec #'(name super) [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
#:with new-spec #'(name super)) opts:struct-options)
(pattern name:id (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
#:with super #f [cname (datum->syntax #f (format-symbol "make-~a" (syntax-e #'nm.name)))])
#:attr old-spec #'name (with-syntax ([d-s (syntax-property (quasisyntax/loc stx
#:with new-spec #'(name))) (struct #,@(attribute nm.new-spec) (fs.fld ...)
(define-splicing-syntax-class maybe-type-vars #:extra-constructor-name #,cname
#:description "optional list of type variables" . opts))
#:attributes ((vars 1)) 'typechecker:ignore #t)]
(pattern (vars:id ...)) [dtsi (quasisyntax/loc stx
(pattern (~seq) #:attr (vars 1) null)) (dtsi* (vars.vars ...)
nm.old-spec (fs ...)
#:maker #,cname
(define (mutable? opts) #,@mutable?))])
(if (memq '#:mutable (syntax->datum opts)) '(#:mutable) '())) #'(begin d-s dtsi)))]))))
(values
(lambda (stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) . opts)
(let ([mutable (mutable? #'opts)])
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (quasisyntax/loc stx (dtsi* (vars.vars ...) nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]))
(lambda (stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...) . opts)
(let ([mutable (mutable? #'opts)]
[cname (datum->syntax #f (format-symbol "make-~a" (syntax-e #'nm.name)))])
(with-syntax ([d-s (syntax-property (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...)
#:extra-constructor-name #,cname
. opts))
'typechecker:ignore #t)]
[dtsi (quasisyntax/loc stx (dtsi* (vars.vars ...) nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
#'(begin d-s dtsi)))])))))
;Copied from racket/private/define-struct ;Copied from racket/private/define-struct