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

providing static struct information to untyped code works

Browse Source 
svn: r18198

original commit: 33c18b3985bce1bab5028c67e06eec5335722eb4
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-19 23:27:06 +00:00
parent ae00f56a11
commit b0a08fe0b8
11 changed files with 227 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/tests/typed-scheme/fail/cnt-struct-err.ss Normal file
View File

@ -0,0 +1,18 @@
#;
(exn-pred exn:fail:contract?)
#lang scheme/load
(module m typed-scheme
(define-struct: x ([f : (Number -> Number)]))
(: my-x x)
(define my-x (make-x (lambda: ([z : Number]) z)))
(provide (all-defined-out)))
(module n2 scheme/base
(require 'm scheme/match)
(match my-x
[(struct x (f)) (f #f)]))
(require 'n2)

3
collects/tests/typed-scheme/fail/struct-provide.ss
View File

@ -3,7 +3,8 @@
#lang scheme/load
(module m typed-scheme
(define-struct: q ())
(require (for-syntax scheme/base))
(define-syntax (q stx) #'#f)
(provide (all-defined-out)))
(module n scheme

16
collects/tests/typed-scheme/succeed/provide-struct-untyped.ss Normal file
View File

@ -0,0 +1,16 @@
#lang scheme/load
(module m typed-scheme
(define-struct: x ([f : (Number -> Number)]))
(: my-x x)
(define my-x (make-x (lambda: ([z : Number]) z)))
(provide (all-defined-out)))
(module n2 scheme/base
(require 'm scheme/match)
(match my-x
[(struct x (f)) (f 7)]))
(require 'n2)

27
collects/typed-scheme/private/prims.ss
View File

@ -241,6 +241,25 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typechecker:with-handlers
#t))]))
(define-syntax (dtsi* stx)
(define-syntax-class struct-name
#:description "struct name (with optional super-struct name)"
#:attributes (name super value)
(pattern ((~var name (static struct-info? "struct name")) super:id)
#: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)))]))
(define-syntax (define-typed-struct stx)
(define-syntax-class fld-spec
#:literals (:)
@ -259,12 +278,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
'())])
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (internal (quasisyntax/loc stx (define-typed-struct-internal nm (fs ...) #,@mutable)))])
[dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (internal (syntax/loc stx (define-typed-struct-internal (vars ...) nm (fs ...))))])
[dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))])
#'(begin d-s dtsi))]))
(define-syntax (require-typed-struct stx)
@ -283,7 +302,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(reverse (list #'sel ...))
(list mut ...)
#f))))
#,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
(dtsi* () nm ([fld : ty] ...) #:type-only)
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker #f)
@ -304,7 +323,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(list #'sel ...)
(list mut ...)
#f))))
#,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only))
(dtsi* () (nm parent) ([fld : ty] ...) #:type-only)
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker parent)

8
collects/typed-scheme/private/type-contract.ss
View File

@ -13,7 +13,8 @@
(private parse-type)
scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list
(only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
(for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) (only-in scheme/class object% is-a?/c subclass?/c)))
(for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap)
(only-in scheme/class object% is-a?/c subclass?/c object-contract)))
(define (define/fixup-contract? stx)
(or (syntax-property stx 'typechecker:contract-def)
@ -135,7 +136,10 @@
(parameterize ([vars (cons (list n #'n* #'n*) (vars))])
#`(flat-rec-contract n* #,(t->c b)))))]
[(Value: #f) #'false/c]
[(Instance: _) #'(is-a?/c object%)]
[(Instance: (Class: _ _ (list (list name fcn) ...)))
(with-syntax ([(fcn-cnts ...) (map t->c fcn)]
[(names ...) name])
#'(object-contract (names fcn-cnts) ...))]
[(Class: _ _ _) #'(subclass?/c object%)]
[(Value: '()) #'null?]
[(Struct: nm par flds proc poly? pred? cert acc-ids)

4
collects/typed-scheme/rep/type-rep.ss
View File

@ -222,6 +222,10 @@
acc-ids)]
[#:key #f])
;; A structure type descriptor
;; s : struct
(dt StructType ([s Struct?]) [#:key 'struct-type])
;; the supertype of all of these values
(dt BoxTop () [#:fold-rhs #:base] [#:key 'box])
(dt VectorTop () [#:fold-rhs #:base] [#:key 'vector])

10
collects/typed-scheme/typecheck/def-binding.ss
View File

@ -1,11 +1,13 @@
#lang scheme/base
(require scheme/contract)
(require scheme/contract "../utils/utils.ss" scheme/struct-info)
(define-struct binding (name) #:transparent)
(define-struct (def-binding binding) (ty) #:transparent)
(define-struct (def-stx-binding binding) () #:transparent)
(define-struct (def-struct-stx-binding def-stx-binding) (static-info) #:transparent)
(provide/contract (struct binding ([name identifier?]))
(struct (def-binding binding) ([name identifier?] [ty any/c]))
(struct (def-stx-binding binding) ([name identifier?])))
(p/c (struct binding ([name identifier?]))
(struct (def-binding binding) ([name identifier?] [ty any/c]))
(struct (def-stx-binding binding) ([name identifier?]))
(struct (def-struct-stx-binding binding) ([name identifier?] [static-info (or/c #f struct-info?)])))

218
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -9,9 +9,10 @@
(private typed-renaming)
(rep type-rep)
(utils tc-utils)
scheme/contract/private/provide
unstable/syntax
"def-binding.ss")
scheme/contract/private/provide unstable/list
unstable/debug
unstable/syntax scheme/struct-info scheme/match
"def-binding.ss" syntax/parse)
(require (for-template scheme/base
scheme/contract))
@ -20,105 +21,136 @@
get-alternate)
(define (provide? form)
(kernel-syntax-case form #f
(syntax-parse form
#:literals (#%provide)
[(#%provide . rest) form]
[_ #f]))
(define (remove-provides forms)
(filter (lambda (e) (not (provide? e))) (syntax->list forms)))
(define (renamer id #:alt [alt #f])
(if alt
(make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
(make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
(define (generate-prov stx-defs val-defs pos-blame-id)
(define mapping (make-free-identifier-mapping))
(lambda (form)
(define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f]))
(define (lookup-id i vd)
(def-binding-ty (mem? i vd)))
(define (mk internal-id external-id)
(cond
;; if it's already done, do nothing
[(free-identifier-mapping-get mapping internal-id
;; if it wasn't there, put it in, and skip this case
(lambda ()
(free-identifier-mapping-put! mapping internal-id #t)
#f))
#'(begin)]
[(mem? internal-id val-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
=>
(lambda (cnt)
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]
[module-source pos-blame-id]
[the-contract (generate-temporary 'generated-contract)])
#`(begin
(define the-contract #,cnt)
(define-syntax cnt-id
(make-provide/contract-transformer
(quote-syntax the-contract)
(quote-syntax id)
(quote-syntax out-id)
(quote-syntax module-source)))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'cnt-id)
(renamer #'cnt-id)))
(#%provide (rename export-id out-id)))))]
[else
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax error-id
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'error-id)
(renamer #'error-id)))
(provide (rename-out [export-id out-id]))))])))]
[(mem? internal-id stx-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax error-id
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))
(define-syntax export-id
(if (unbox typed-context?)
(begin
(add-alias #'export-id #'id)
(renamer #'id #:alt #'error-id))
(renamer #'error-id)))
(provide (rename-out [export-id out-id]))))))]
[(eq? (syntax-e internal-id) (syntax-e external-id))
#`(provide #,internal-id)]
[else #`(provide (rename-out [#,internal-id #,external-id]))]))
(kernel-syntax-case form #f
;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
(define mapping (make-free-identifier-mapping))
(define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f]))
;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax
;; val-defs: define-values in this module
;; stx-defs: define-syntaxes in this module
;; pos-blame-id: a #%variable-reference for the module
;; internal-id : the id being provided
;; if `internal-id' is defined in this module, we will produce a (begin def ... provide) block
;; and a name to provide instead of internal-id
;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id
;; otherwise, we will map internal-id to the fresh id in `mapping'
(define ((generate-prov stx-defs val-defs pos-blame-id) form)
;; mk : id [id] -> (values syntax id)
(define (mk internal-id [new-id (generate-temporary internal-id)])
(cond
;; if it's already done, do nothing
[(free-identifier-mapping-get mapping internal-id
;; if it wasn't there, put it in, and skip this case
(lambda ()
(free-identifier-mapping-put! mapping internal-id new-id)
#f))
=> (lambda (mapped-id)
(values #'(begin) mapped-id))]
[(mem? internal-id val-defs)
=>
(lambda (b)
(values
(with-syntax ([id internal-id])
(cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
=>
(lambda (cnt)
(with-syntax ([(cnt-id) (generate-temporaries #'(id))]
[export-id new-id]
[module-source pos-blame-id]
[the-contract (generate-temporary 'generated-contract)])
#`(begin
(define the-contract #,cnt)
(define-syntax cnt-id
(make-provide/contract-transformer
(quote-syntax the-contract)
(quote-syntax id)
(quote-syntax out-id)
(quote-syntax module-source)))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'cnt-id)
(renamer #'cnt-id))))))]
[else
(with-syntax ([(error-id) (generate-temporaries #'(id))]
[export-id new-id])
#`(begin
(define-syntax error-id
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'error-id)
(renamer #'error-id)))))]))
new-id))]
[(mem? internal-id stx-defs)
=>
(lambda (b)
(define (mk-untyped-syntax defn-id internal-id)
(match b
[(struct def-struct-stx-binding (_ (? struct-info? si)))
(match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)])
(let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e)
(mk e)
(values #'(begin) e)))
(list* type-desc constr pred super accs))])
(with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids])
(if (identifier? i)
#`(syntax #,i)
i))])
#`(begin
#,@defns
(define-syntax #,defn-id
(list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))]
[_
#`(define-syntax #,defn-id
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))]))
(with-syntax* ([id internal-id]
[export-id new-id]
[(untyped-id) (generate-temporaries #'(id))])
(values
#`(begin
#,(mk-untyped-syntax #'untyped-id internal-id)
(define-syntax export-id
(if (unbox typed-context?)
(begin
(add-alias #'export-id #'id)
(renamer #'id #:alt #'untyped-id))
(renamer #'untyped-id))))
new-id)))]
;; otherwise, not defined in this module, not our problem
[else (values #'(begin) internal-id)]))
;; do-one : id [id] -> syntax
(define (do-one internal-id [external-id internal-id])
(define-values (defs id) (mk internal-id))
#`(begin #,defs (provide (rename-out [#,id #,external-id]))))
(syntax-parse form #:literals (#%provide)
[(#%provide form ...)
(map
(lambda (f)
(parameterize ([current-orig-stx f])
(syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except)
(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[id
(identifier? #'id)
(mk #'id #'id)]
[(rename in out)
(mk #'in #'out)]
[(protect . _)
(tc-error "provide: protect not supported by Typed Scheme")]
[_ (int-err "unknown provide form")])))
(syntax->list #'(form ...)))]
[_ (int-err "non-provide form! ~a" (syntax->datum form))])))
(for/list ([f (syntax->list #'(form ...))])
(parameterize ([current-orig-stx f])
(syntax-parse f
[i:id
(do-one #'i)]
[((~datum rename) in out)
(do-one #'in #'out)]
[((~datum protect) . _)
(tc-error "provide: protect not supported by Typed Scheme")]
[_ (int-err "unknown provide form")])))]
[_ (int-err "non-provide form! ~a" (syntax->datum form))]))

31
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -66,11 +66,11 @@
(values (reverse getters) (reverse setters))
(loop (cddr l) (cons (car l) getters) (cons (cadr l) setters)))))
(match (build-struct-names nm flds #f (not setters?) nm)
[(list _ maker pred getters/setters ...)
[(list sty maker pred getters/setters ...)
(if setters?
(let-values ([(getters setters) (split getters/setters)])
(values maker pred getters setters))
(values maker pred getters/setters #f))]))
(values sty maker pred getters setters))
(values sty maker pred getters/setters #f))]))
;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type]
@ -88,6 +88,7 @@
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:mutable [setters? #f]
#:struct-info [si #f]
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:predicate [pred* #f]
@ -95,7 +96,7 @@
#:poly? [poly? #f]
#:type-only [type-only #f])
;; create the approriate names that define-struct will bind
(define-values (maker pred getters setters) (struct-names nm flds setters?))
(define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
(let* ([name (syntax-e nm)]
[fld-types (append parent-field-types types)]
[sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters)]
@ -109,6 +110,7 @@
#:pred-wrapper pred-wrapper
#:maker (or maker* maker)
#:predicate (or pred* pred)
#:struct-info si
#:constructor-return cret))))
;; generate names, and register the approriate types give field types and structure type
@ -116,24 +118,28 @@
;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper values]
#:struct-info [si #f]
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f])
;; create the approriate names that define-struct will bind
(define-values (maker pred getters setters) (struct-names nm flds setters?))
(define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
;; the type name that is used in all the types
(define name (type-wrapper (make-Name nm)))
;; the list of names w/ types
(define bindings
(append
(list (cons (or maker* maker)
(wrapper (->* external-fld-types (if cret cret name))))
(cons (or pred* pred)
(make-pred-ty (if setters?
(make-StructTop sty)
(pred-wrapper name)))))
(list
(cons struct-type-id
(make-StructType sty))
(cons (or maker* maker)
(wrapper (->* external-fld-types (if cret cret name))))
(cons (or pred* pred)
(make-pred-ty (if setters?
(make-StructTop sty)
(pred-wrapper name)))))
(for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
(let ([func (if setters?
(->* (list name) t)
@ -146,7 +152,7 @@
null)))
(register-type-name nm (wrapper sty))
(cons
(make-def-stx-binding nm)
(make-def-struct-stx-binding nm si)
(for/list ([e bindings])
(let ([nm (car e)]
[t (cdr e)])
@ -207,6 +213,7 @@
#:proc-ty proc-ty-parsed
#:maker maker
#:predicate pred
#:struct-info (syntax-property nm/par 'struct-info)
#:constructor-return (and cret (parse-type cret))
#:mutable mutable
#:type-only type-only))

6
collects/typed-scheme/types/subtype.ss
View File

@ -333,6 +333,12 @@
(subtype* A0 t t*)]
[((Instance: t) (Instance: t*))
(subtype* A0 t t*)]
[((Class: '() '() (list (and s (list names meths )) ...))
(Class: '() '() (list (and s* (list names* meths*)) ...)))
(for/fold ([A A0])
([n names*] [m meths*])
(cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
[else (fail! s t)]))]
;; otherwise, not a subtype
[(_ _) (fail! s t) #;(printf "failed")])))]))))

6
collects/typed-scheme/utils/utils.ss
View File

@ -172,11 +172,9 @@ at least theoretically.
(define-syntax-class clause
#:literals ()
#:attributes (i)
(pattern [struct nm:id (flds ...)]
#:fail-unless (eq? (syntax-e #'struct) 'struct) #f
(pattern [(~datum struct) (~or nm:id (nm:id super:id)) (flds ...)]
#:with i #'(struct-out nm))
(pattern [rename out:id in:id cnt:expr]
#:fail-unless (eq? (syntax-e #'rename) 'rename) #f
(pattern [(~datum rename) out:id in:id cnt:expr]
#:with i #'(rename-out [out in]))
(pattern [i:id cnt:expr]))
(syntax-parse stx