Improve contract generation in Typed Racket.
This fixes several issues: - `Parameter` generates impersonator contracts correctly - `Any` handling now copies immutable data when possible - `Any` now recognizes more atomic base types Merge to 5.3.1.
This commit is contained in:
parent
cb566b1ba4
commit
c6dc1e6ece
7
collects/tests/typed-racket/succeed/parameter-c.rkt
Normal file
7
collects/tests/typed-racket/succeed/parameter-c.rkt
Normal file
|
@ -0,0 +1,7 @@
|
||||||
|
#lang typed/racket/base
|
||||||
|
|
||||||
|
(require/typed
|
||||||
|
rackunit
|
||||||
|
[current-check-around (Parameter Any)])
|
||||||
|
|
||||||
|
|
11
collects/tests/typed-racket/succeed/vector-chap.rkt
Normal file
11
collects/tests/typed-racket/succeed/vector-chap.rkt
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
#lang racket/load
|
||||||
|
|
||||||
|
(module m1 racket
|
||||||
|
(define (f x y) (equal? x y))
|
||||||
|
(provide f))
|
||||||
|
|
||||||
|
(module m2 typed/racket
|
||||||
|
(require/typed 'm1 [f (Any Any -> Boolean)])
|
||||||
|
(f (vector 1 2) (vector 1 2)))
|
||||||
|
|
||||||
|
(require 'm2)
|
|
@ -54,14 +54,24 @@
|
||||||
(let ([typ (if maker?
|
(let ([typ (if maker?
|
||||||
((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
|
((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
|
||||||
typ)])
|
typ)])
|
||||||
(with-syntax ([cnt (type->contract
|
(with-syntax ([cnt (type->contract
|
||||||
typ
|
typ
|
||||||
;; this is for a `require/typed', so the value is not from the typed side
|
;; this is for a `require/typed', so the value is not from the typed side
|
||||||
#:typed-side #f
|
#:typed-side #f
|
||||||
#:kind kind
|
#:kind kind
|
||||||
(lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
|
(λ ()
|
||||||
(quasisyntax/loc stx (define-values (n) (recursive-contract cnt #,(contract-kind->keyword kind))))))]
|
(tc-error/stx
|
||||||
[_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
|
prop
|
||||||
|
"Type ~a could not be converted to a contract."
|
||||||
|
typ)))])
|
||||||
|
(quasisyntax/loc
|
||||||
|
stx
|
||||||
|
(define-values (n)
|
||||||
|
(recursive-contract
|
||||||
|
cnt
|
||||||
|
#,(contract-kind->keyword kind))))))]
|
||||||
|
[_ (int-err "should never happen - not a define-values: ~a"
|
||||||
|
(syntax->datum stx))]))
|
||||||
|
|
||||||
(define (change-contract-fixups forms)
|
(define (change-contract-fixups forms)
|
||||||
(map (lambda (e)
|
(map (lambda (e)
|
||||||
|
@ -89,7 +99,6 @@
|
||||||
(for/fold ((acc i)) ((v args))
|
(for/fold ((acc i)) ((v args))
|
||||||
(contract-kind-max2 v acc)))
|
(contract-kind-max2 v acc)))
|
||||||
|
|
||||||
|
|
||||||
(define (contract-kind-min i . args)
|
(define (contract-kind-min i . args)
|
||||||
(define (contract-kind-min2 x y)
|
(define (contract-kind-min2 x y)
|
||||||
(cond
|
(cond
|
||||||
|
@ -106,7 +115,7 @@
|
||||||
(string->keyword (symbol->string sym)))
|
(string->keyword (symbol->string sym)))
|
||||||
|
|
||||||
(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:kind [kind 'impersonator])
|
(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:kind [kind 'impersonator])
|
||||||
(define vars (make-parameter '()))
|
(define vars (make-parameter '()))
|
||||||
(define current-contract-kind (make-parameter flat-sym))
|
(define current-contract-kind (make-parameter flat-sym))
|
||||||
(define (increase-current-contract-kind! kind)
|
(define (increase-current-contract-kind! kind)
|
||||||
(current-contract-kind (contract-kind-max (current-contract-kind) kind)))
|
(current-contract-kind (contract-kind-max (current-contract-kind) kind)))
|
||||||
|
@ -138,7 +147,9 @@
|
||||||
[(and
|
[(and
|
||||||
(> (length arrs) 1)
|
(> (length arrs) 1)
|
||||||
;; Keyword args, range and rest specs all the same.
|
;; Keyword args, range and rest specs all the same.
|
||||||
(let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws) (list rng rest-spec kws)]) arrs)])
|
(let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
|
||||||
|
(list rng rest-spec kws)])
|
||||||
|
arrs)])
|
||||||
(foldl equal? (first xs) (rest xs)))
|
(foldl equal? (first xs) (rest xs)))
|
||||||
;; Positionals are monotonically increasing.
|
;; Positionals are monotonically increasing.
|
||||||
(let-values ([(_ ok?)
|
(let-values ([(_ ok?)
|
||||||
|
@ -338,11 +349,13 @@
|
||||||
(match-let ([(Mu-name: n-nm _) ty])
|
(match-let ([(Mu-name: n-nm _) ty])
|
||||||
(with-syntax ([(n*) (generate-temporaries (list n-nm))])
|
(with-syntax ([(n*) (generate-temporaries (list n-nm))])
|
||||||
(parameterize ([vars (cons (list n #'n*) (vars))]
|
(parameterize ([vars (cons (list n #'n*) (vars))]
|
||||||
[current-contract-kind (contract-kind-min kind chaperone-sym)])
|
[current-contract-kind
|
||||||
|
(contract-kind-min kind chaperone-sym)])
|
||||||
(define ctc (t->c b))
|
(define ctc (t->c b))
|
||||||
#`(letrec ([n* (recursive-contract
|
#`(letrec ([n* (recursive-contract
|
||||||
#,ctc
|
#,ctc
|
||||||
#,(contract-kind->keyword (current-contract-kind)))])
|
#,(contract-kind->keyword
|
||||||
|
(current-contract-kind)))])
|
||||||
n*))))]
|
n*))))]
|
||||||
[(Value: #f) #'false/c]
|
[(Value: #f) #'false/c]
|
||||||
[(Instance: (? Mu? t))
|
[(Instance: (? Mu? t))
|
||||||
|
@ -389,7 +402,9 @@
|
||||||
#`(syntax/c #,(t->c t #:kind flat-sym))]
|
#`(syntax/c #,(t->c t #:kind flat-sym))]
|
||||||
[(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]
|
[(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]
|
||||||
;; TODO Is this sound?
|
;; TODO Is this sound?
|
||||||
[(Param: in out) #`(parameter/c #,(t->c out))]
|
[(Param: in out)
|
||||||
|
(set-impersonator!)
|
||||||
|
#`(parameter/c #,(t->c out))]
|
||||||
[(Hashtable: k v)
|
[(Hashtable: k v)
|
||||||
(when (equal? kind flat-sym) (exit (fail)))
|
(when (equal? kind flat-sym) (exit (fail)))
|
||||||
#`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)]
|
#`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)]
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require racket/match racket/contract/base racket/contract/combinator)
|
(require racket/match racket/contract/base racket/contract/combinator racket/flonum racket/fixnum)
|
||||||
|
|
||||||
(define undef (letrec ([x x]) x))
|
(define undef (letrec ([x x]) x))
|
||||||
|
|
||||||
(define (traverse b)
|
(define (traverse b)
|
||||||
(define (fail v)
|
(define (fail v)
|
||||||
(raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`"))
|
(raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any` in untyped code"))
|
||||||
|
|
||||||
(define (t v)
|
(define (t v)
|
||||||
(define (wrap-struct s)
|
(define (wrap-struct s)
|
||||||
|
@ -43,10 +43,25 @@
|
||||||
(match v
|
(match v
|
||||||
[(? (lambda (e)
|
[(? (lambda (e)
|
||||||
(or (number? e) (string? e) (char? e) (symbol? e)
|
(or (number? e) (string? e) (char? e) (symbol? e)
|
||||||
(null? e) (regexp? e) (eq? undef e)
|
(null? e) (regexp? e) (eq? undef e) (path? e)
|
||||||
|
(flvector? e) (flvector? e) (regexp? e)
|
||||||
(keyword? e) (bytes? e) (boolean? e) (void? e))))
|
(keyword? e) (bytes? e) (boolean? e) (void? e))))
|
||||||
v]
|
v]
|
||||||
[(cons x y) (cons (t x) (t y))]
|
[(cons x y) (cons (t x) (t y))]
|
||||||
|
[(? vector? (? immutable?))
|
||||||
|
;; fixme -- should have an immutable for/vector
|
||||||
|
(vector->immutable-vector
|
||||||
|
(for/vector #:length (vector-length v)
|
||||||
|
([i (in-vector v)]) (t i)))]
|
||||||
|
[(? box? (? immutable?)) (box-immutable (t (unbox v)))]
|
||||||
|
;; fixme -- handling keys
|
||||||
|
;; [(? hasheq? (? immutable?))
|
||||||
|
;; (for/hasheq ([(k v) (in-hash v)]) (values k v))]
|
||||||
|
;; [(? hasheqv? (? immutable?))
|
||||||
|
;; (for/hasheqv ([(k v) (in-hash v)]) (values k v))]
|
||||||
|
|
||||||
|
[(? hash? (? immutable?))
|
||||||
|
(for/hash ([(k v) (in-hash v)]) (values (t k) (t v)))]
|
||||||
[(? vector?) (chaperone-vector v
|
[(? vector?) (chaperone-vector v
|
||||||
(lambda (v i e) (t e))
|
(lambda (v i e) (t e))
|
||||||
(lambda (v i e) (fail v)))]
|
(lambda (v i e) (fail v)))]
|
||||||
|
|
Loading…
Reference in New Issue
Block a user