From 90ef1eac370d3e6a331dc776e6c7852daadc9c61 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Tue, 21 Aug 2012 08:52:23 -0700 Subject: [PATCH] Fix type->contract on structures. Now uses struct/c. original commit: 9e1cf579a434b65e484bdf937e3307bc3c9fd7aa --- .../succeed/contract-struct-equality.rkt | 23 ++++ collects/typed-racket/base-env/prims.rkt | 2 +- .../typed-racket/private/type-contract.rkt | 106 ++++++++---------- 3 files changed, 71 insertions(+), 60 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/contract-struct-equality.rkt diff --git a/collects/tests/typed-racket/succeed/contract-struct-equality.rkt b/collects/tests/typed-racket/succeed/contract-struct-equality.rkt new file mode 100644 index 00000000..9fec8875 --- /dev/null +++ b/collects/tests/typed-racket/succeed/contract-struct-equality.rkt @@ -0,0 +1,23 @@ +#lang racket/load + +(module typed typed/racket + (provide g) + (struct: (A) foo ((v : A))) + (: f (foo Byte)) + (define f (foo 2)) + (: g (-> (foo Byte))) + (define (g) f)) + +(module typed-client typed/racket + (require 'typed) + (unless (equal? (g) (g)) + (error 'typed2 "Failed"))) + + +(module untyped-client racket + (require 'typed) + (unless (equal? (g) (g)) + (error 'typed2 "Failed"))) + +(require 'typed-client) +(require 'untyped-client) diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt index d5043019..8d0a8816 100644 --- a/collects/typed-racket/base-env/prims.rkt +++ b/collects/typed-racket/base-env/prims.rkt @@ -223,7 +223,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (type->contract typ ;; must be a flat contract - #:flat #t + #:kind 'flat ;; the value is not from the typed side #:typed-side #f (lambda () (tc-error/stx #'ty "Type ~a could not be converted to a predicate." typ))) diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index d64a23cf..b201195c 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -57,9 +57,9 @@ typ ;; this is for a `require/typed', so the value is not from the typed side #:typed-side #f - #:flat flat? + #:kind (if flat? 'flat 'impersonator) (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))]) - (quasisyntax/loc stx (define-values (n) (recursive-contract cnt #,(if flat? #'#:flat #'#:impersonator))))))] + (quasisyntax/loc stx (define-values (n) cnt))))] [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))])) (define (change-contract-fixups forms) @@ -72,20 +72,20 @@ (define (no-duplicates l) (= (length l) (length (remove-duplicates l)))) - -(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:flat [flat? #f]) +;(require racket/trace) +(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:kind [kind 'impersonator]) (define vars (make-parameter '())) (let/ec exit - (let loop ([ty ty] [pos? #t] [from-typed? from-typed?] [structs-seen null] [flat? flat?]) - (define (t->c t #:seen [structs-seen structs-seen] #:flat [flat? flat?]) - (loop t pos? from-typed? structs-seen flat?)) - (define (t->c/neg t #:seen [structs-seen structs-seen] #:flat [flat? flat?]) - (loop t (not pos?) (not from-typed?) structs-seen flat?)) + (let loop ([ty ty] [pos? #t] [from-typed? from-typed?] [structs-seen null] [kind kind]) + (define (t->c t #:seen [structs-seen structs-seen] #:kind [kind kind]) + (loop t pos? from-typed? structs-seen kind)) + (define (t->c/neg t #:seen [structs-seen structs-seen] #:flat [kind kind]) + (loop t (not pos?) (not from-typed?) structs-seen kind)) (define (t->c/fun f #:method [method? #f]) (match f [(Function: (list (top-arr:))) #'procedure?] [(Function: arrs) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) (let () (define ((f [case-> #f]) a) (define-values (dom* opt-dom* rngs* rst) @@ -136,7 +136,13 @@ (match ty [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))] ;; any/c doesn't provide protection in positive position - [(Univ:) (if from-typed? #'any-wrap/c #'any/c)] + [(Univ:) + (cond + ((and from-typed? (equal? kind 'impersonator)) + #'any-wrap/c) + ((not from-typed?) + #'any/c) + (else (exit (fail))))] ;; we special-case lists: [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (if (and (not from-typed?) (type-equal? elem-ty t:Univ)) @@ -208,18 +214,18 @@ [(Set: t) #`(set/c #,(t->c t))] [(Sequence: ts) #`(sequence/c #,@(map t->c ts))] [(Vector: t) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) #`(vectorof #,(t->c t))] [(HeterogenousVector: ts) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) #`(vector/c #,@(map t->c ts))] [(Box: t) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) #`(box/c #,(t->c t))] [(Pair: t1 t2) #`(cons/c #,(t->c t1) #,(t->c t2))] [(Promise: t) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) #`(promise/c #,(t->c t))] [(Opaque: p? cert) #`(flat-named-contract (quote #,(syntax-e p?)) #,(cert p?))] @@ -240,17 +246,22 @@ (match-let ([(Mu-name: n-nm _) ty]) (with-syntax ([(n*) (generate-temporaries (list n-nm))]) (parameterize ([vars (cons (list n #'n* #'n*) (vars))]) - #`(letrec ([n* (recursive-contract #,(t->c b) #,(if flat? #'#:flat #'#:impersonator))]) + #`(letrec ([n* (recursive-contract + #,(t->c b) + #,(case kind + ((flat) #'#:flat) + ((chaperone) #'#:chaperone) + ((impersonator) #'#:impersonator)))]) n*))))] [(Value: #f) #'false/c] [(Instance: (Class: _ _ (list (list name fcn) ...))) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) (with-syntax ([(fcn-cnts ...) (for/list ([f fcn]) (t->c/fun f #:method #t))] [(names ...) name]) #'(object/c (names fcn-cnts) ...))] ;; init args not currently handled by class/c [(Class: _ (list (list by-name-init by-name-init-ty _) ...) (list (list name fcn) ...)) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) (with-syntax ([(fcn-cnt ...) (for/list ([f fcn]) (t->c/fun f #:method #t))] [(name ...) name] [(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))] @@ -263,54 +274,31 @@ => cdr] [proc (exit (fail))] - [(and flat? (ormap values mut?)) + [(and (equal? kind 'flat) (ormap values mut?)) (exit (fail))] [poly? - (with-syntax* ([(rec blame val) (generate-temporaries '(rec blame val))] - [maker maker-id] - [cnt-name nm]) - ;If it should be a flat contract, we make flat contracts for the type of each field, - ;extract the predicates, and apply the predicates to the corresponding field value - (if flat? - #`(letrec ([rec - (make-flat-contract - #:name 'cnt-name - #:first-order - (lambda (val) - (and - (#,pred? val) - #,@(for/list ([fty flds] [f-acc acc-ids]) - #`((flat-contract-predicate - #,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec #:flat)) structs-seen))) - (#,f-acc val))))))]) - rec) - ;Should make this case a chaperone/impersonator contract - (with-syntax ([(fld-cnts ...) - (for/list ([fty flds] - [f-acc acc-ids] - [m? mut?]) - #`(((contract-projection - #,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen))) - blame) - (#,f-acc val)))]) - #`(letrec ([rec - (make-contract - #:name 'cnt-name - #:first-order #,pred? - #:projection - (lambda (blame) - (lambda (val) - (unless (#,pred? val) - (raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val)) - (maker fld-cnts ...))))]) - rec))))] - [else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])] + (with-syntax* ([rec (generate-temporary 'rec)]) + (define field-contracts + (for/list ([fty flds] [mut? mut?]) + (define rec-kind + (cond + ((equal? kind 'flat) 'flat) + ((equal? kind 'chaperone) 'chaperone) + ((not mut?) 'chaperone) + (else 'impersonator))) + (define rec-kind-kw (string->keyword (symbol->string rec-kind))) + + (t->c fty #:seen (cons (cons ty #`(recursive-contract rec #,rec-kind-kw)) + structs-seen) + #:kind rec-kind))) + #`(letrec ((rec (struct/c #,nm #,@field-contracts))) rec))] + [else #`(flat-named-contract '#,(syntax-e pred?) (lambda (x) (#,(cert pred?) x)))])] [(Syntax: (Base: 'Symbol _ _ _ _)) #'identifier?] [(Syntax: t) #`(syntax/c #,(t->c t))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] [(Param: in out) #`(parameter/c #,(t->c out))] [(Hashtable: k v) - (when flat? (exit (fail))) + (when (equal? kind 'flat) (exit (fail))) #`(hash/c #,(t->c k) #,(t->c v) #:immutable 'dont-care)] [else (exit (fail))]))))