Skip to content

Commit c6dc1e6

Browse files
samthsamth
committed
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.
1 parent cb566b1 commit c6dc1e6

File tree

4 files changed

+65
-17
lines changed

4 files changed

+65
-17
lines changed

‎collects/tests/typed-racket/succeed/parameter-c.rkt

+7
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
#lang typed/racket/base
2+
3+
(require/typed
4+
rackunit
5+
[current-check-around (Parameter Any)])
6+
7+

‎collects/tests/typed-racket/succeed/vector-chap.rkt

+11
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
#lang racket/load
2+
3+
(module m1 racket
4+
(define (f x y) (equal? x y))
5+
(provide f))
6+
7+
(module m2 typed/racket
8+
(require/typed 'm1 [f (Any Any -> Boolean)])
9+
(f (vector 1 2) (vector 1 2)))
10+
11+
(require 'm2)

‎collects/typed-racket/private/type-contract.rkt

+29-14
Original file line numberDiff line numberDiff line change
@@ -54,14 +54,24 @@
5454
(let ([typ (if maker?
5555
((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
5656
typ)])
57-
(with-syntax ([cnt (type->contract
58-
typ
59-
;; this is for a `require/typed', so the value is not from the typed side
60-
#:typed-side #f
61-
#:kind kind
62-
(lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
63-
(quasisyntax/loc stx (define-values (n) (recursive-contract cnt #,(contract-kind->keyword kind))))))]
64-
[_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
57+
(with-syntax ([cnt (type->contract
58+
typ
59+
;; this is for a `require/typed', so the value is not from the typed side
60+
#:typed-side #f
61+
#:kind kind
62+
(λ ()
63+
(tc-error/stx
64+
prop
65+
"Type ~a could not be converted to a contract."
66+
typ)))])
67+
(quasisyntax/loc
68+
stx
69+
(define-values (n)
70+
(recursive-contract
71+
cnt
72+
#,(contract-kind->keyword kind))))))]
73+
[_ (int-err "should never happen - not a define-values: ~a"
74+
(syntax->datum stx))]))
6575

6676
(define (change-contract-fixups forms)
6777
(map (lambda (e)
@@ -89,7 +99,6 @@
8999
(for/fold ((acc i)) ((v args))
90100
(contract-kind-max2 v acc)))
91101

92-
93102
(define (contract-kind-min i . args)
94103
(define (contract-kind-min2 x y)
95104
(cond
@@ -106,7 +115,7 @@
106115
(string->keyword (symbol->string sym)))
107116

108117
(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:kind [kind 'impersonator])
109-
(define vars (make-parameter '()))
118+
(define vars (make-parameter '()))
110119
(define current-contract-kind (make-parameter flat-sym))
111120
(define (increase-current-contract-kind! kind)
112121
(current-contract-kind (contract-kind-max (current-contract-kind) kind)))
@@ -138,7 +147,9 @@
138147
[(and
139148
(> (length arrs) 1)
140149
;; Keyword args, range and rest specs all the same.
141-
(let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws) (list rng rest-spec kws)]) arrs)])
150+
(let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
151+
(list rng rest-spec kws)])
152+
arrs)])
142153
(foldl equal? (first xs) (rest xs)))
143154
;; Positionals are monotonically increasing.
144155
(let-values ([(_ ok?)
@@ -338,11 +349,13 @@
338349
(match-let ([(Mu-name: n-nm _) ty])
339350
(with-syntax ([(n*) (generate-temporaries (list n-nm))])
340351
(parameterize ([vars (cons (list n #'n*) (vars))]
341-
[current-contract-kind (contract-kind-min kind chaperone-sym)])
352+
[current-contract-kind
353+
(contract-kind-min kind chaperone-sym)])
342354
(define ctc (t->c b))
343355
#`(letrec ([n* (recursive-contract
344356
#,ctc
345-
#,(contract-kind->keyword (current-contract-kind)))])
357+
#,(contract-kind->keyword
358+
(current-contract-kind)))])
346359
n*))))]
347360
[(Value: #f) #'false/c]
348361
[(Instance: (? Mu? t))
@@ -389,7 +402,9 @@
389402
#`(syntax/c #,(t->c t #:kind flat-sym))]
390403
[(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]
391404
;; TODO Is this sound?
392-
[(Param: in out) #`(parameter/c #,(t->c out))]
405+
[(Param: in out)
406+
(set-impersonator!)
407+
#`(parameter/c #,(t->c out))]
393408
[(Hashtable: k v)
394409
(when (equal? kind flat-sym) (exit (fail)))
395410
#`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)]

‎collects/typed-racket/utils/any-wrap.rkt

+18-3
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,12 @@
11
#lang racket/base
22

3-
(require racket/match racket/contract/base racket/contract/combinator)
3+
(require racket/match racket/contract/base racket/contract/combinator racket/flonum racket/fixnum)
44

55
(define undef (letrec ([x x]) x))
66

77
(define (traverse b)
88
(define (fail v)
9-
(raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`"))
9+
(raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any` in untyped code"))
1010

1111
(define (t v)
1212
(define (wrap-struct s)
@@ -43,10 +43,25 @@
4343
(match v
4444
[(? (lambda (e)
4545
(or (number? e) (string? e) (char? e) (symbol? e)
46-
(null? e) (regexp? e) (eq? undef e)
46+
(null? e) (regexp? e) (eq? undef e) (path? e)
47+
(flvector? e) (flvector? e) (regexp? e)
4748
(keyword? e) (bytes? e) (boolean? e) (void? e))))
4849
v]
4950
[(cons x y) (cons (t x) (t y))]
51+
[(? vector? (? immutable?))
52+
;; fixme -- should have an immutable for/vector
53+
(vector->immutable-vector
54+
(for/vector #:length (vector-length v)
55+
([i (in-vector v)]) (t i)))]
56+
[(? box? (? immutable?)) (box-immutable (t (unbox v)))]
57+
;; fixme -- handling keys
58+
;; [(? hasheq? (? immutable?))
59+
;; (for/hasheq ([(k v) (in-hash v)]) (values k v))]
60+
;; [(? hasheqv? (? immutable?))
61+
;; (for/hasheqv ([(k v) (in-hash v)]) (values k v))]
62+
63+
[(? hash? (? immutable?))
64+
(for/hash ([(k v) (in-hash v)]) (values (t k) (t v)))]
5065
[(? vector?) (chaperone-vector v
5166
(lambda (v i e) (t e))
5267
(lambda (v i e) (fail v)))]

0 commit comments

Comments
 (0)