diff --git a/collects/tests/typed-racket/succeed/kw.rkt b/collects/tests/typed-racket/succeed/kw.rkt index 620dd51a..116a6dcc 100644 --- a/collects/tests/typed-racket/succeed/kw.rkt +++ b/collects/tests/typed-racket/succeed/kw.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/scheme (lambda () (open-input-file "foo" #:mode 'binary) @@ -12,3 +12,7 @@ ((inst sort Real String) (list 1 2 3) #:key number->string stringstring string) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index cf03742b..20167645 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -1383,11 +1383,6 @@ [last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) . -> . (Un (-pair a a) (-pair a (-val '())))))] -[remove-duplicates - (-poly (a) - (cl->* - ((-lst a) . -> . (-lst a)) - ((-lst a) (a a . -> . Univ) . -> . (-lst a))))] [append-map (-polydots (c a b) ((list ((list a) (b b) . ->... . (-lst c)) (-lst a)) ((-lst b) b) . ->... .(-lst c)))] diff --git a/collects/typed-racket/base-env/base-special-env.rkt b/collects/typed-racket/base-env/base-special-env.rkt index 050c79f4..2d0ee75a 100644 --- a/collects/typed-racket/base-env/base-special-env.rkt +++ b/collects/typed-racket/base-env/base-special-env.rkt @@ -7,7 +7,7 @@ string-constants/string-constant racket/private/kw racket/file racket/port syntax/parse racket/path (for-template (only-in racket/private/kw kw-expander-proc kw-expander-impl) - racket/base racket/file racket/port racket/path) + racket/base racket/file racket/port racket/path racket/list) (utils tc-utils) (env init-envs) (except-in (rep filter-rep object-rep type-rep) make-arr) @@ -310,6 +310,29 @@ -Boolean -Boolean (a . -> . b) (-val #t) (-lst a) (b b . -> . -Boolean) (-lst a))))] + + [((kw-expander-proc (syntax-local-value #'remove-duplicates))) + (-poly (a b) (cl->* + ((-lst a) . -> . (-lst a)) + ((-lst a) (a a . -> . Univ) + . -> . (-lst a)) + ((-lst a) #:key (a . -> . b) #f + . ->key . (-lst a)) + ((-lst a) (b b . -> . Univ) + #:key (a . -> . b) #t + . ->key . (-lst a))))] + [((kw-expander-impl (syntax-local-value #'remove-duplicates))) + (-poly (a b) + (cl->* + (Univ (-val #f) ;; no key + (-lst a) (-val #f) -Boolean + . -> . (-lst a)) + (Univ (-val #f) ;; no key + (-lst a) (-> a a Univ) -Boolean + . -> . (-lst a)) + ((a . -> . b) (-val #t) ;; no key + (-lst a) (-opt (-> b b Univ)) -Boolean + . -> . (-lst a))))] [((kw-expander-proc (syntax-local-value #'open-input-file))) (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Input-Port)] diff --git a/collects/typed-racket/infer/infer-unit.rkt b/collects/typed-racket/infer/infer-unit.rkt index c54a26c3..719aec1b 100644 --- a/collects/typed-racket/infer/infer-unit.rkt +++ b/collects/typed-racket/infer/infer-unit.rkt @@ -705,7 +705,7 @@ [cs (cgen/list null X Y S T #:expected-cset expected-cset)] [cs* (cset-meet cs expected-cset)]) (if R (subst-gen cs* Y R) #t)))) - infer)) ;to export a variable binding and not syntax + infer)) ;to export a variable binding and not syntax ;; like infer, but T-var is the vararg type: (define (infer/vararg X Y S T T-var R [expected #f]) diff --git a/collects/typed-racket/typecheck/tc-funapp.rkt b/collects/typed-racket/typecheck/tc-funapp.rkt index 723feabd..2386b01f 100644 --- a/collects/typed-racket/typecheck/tc-funapp.rkt +++ b/collects/typed-racket/typecheck/tc-funapp.rkt @@ -105,23 +105,25 @@ [else (infer fixed-vars (list dotted-var) argtys-t dom rng (and expected (tc-results->values expected)))])) t argtys expected)] - ;; regular polymorphic functions without dotted rest, and without mandatory - ;; keyword args + ;; regular polymorphic functions without dotted rest, + ;; we do not choose any instantiations with mandatory keyword arguments [((tc-result1: (and t (Poly: vars (Function: (list (and arrs (arr: doms rngs rests (and drests #f) - (list (Keyword: _ _ #f) ...))) + (list (Keyword: _ _ kw?) ...))) ...))))) (list (tc-result1: argtys-t) ...)) (handle-clauses - (doms rngs rests arrs) f-stx args-stx + (doms rngs rests kw? arrs) f-stx args-stx ;; only try inference if the argument lengths are appropriate - (λ (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) + ;; and there's no mandatory kw + (λ (dom _ rest kw? a) + (and (andmap not kw?) ((if rest <= =) (length dom) (length argtys)))) ;; Only try to infer the free vars of the rng (which includes the vars ;; in filters/objects). Note that we have to use argtys-t here, since ;; argtys is a list of tc-results. - (λ (dom rng rest a) + (λ (dom rng rest kw? a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) t argtys expected)]