diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt index e3d9a91f3d..81c5d150b0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt @@ -302,7 +302,7 @@ (define (cleanup-type t [expected #f]) (match t ;; function type, prune if possible. - [(Function: (list (arr: doms rngs rests drests kws) ...)) + [(Function/arrs: doms rngs rests drests kws) (match-let ([(list pdoms rngs rests drests) (possible-domains doms rests drests rngs (and expected (ret expected)))]) (if (= (length pdoms) (length doms)) ;; pruning didn't improve things, return the original @@ -324,13 +324,13 @@ (match t [(or (Poly-names: msg-vars - (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)) ...))) + (Function/arrs: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...))) (PolyDots-names: msg-vars - (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)) ...))) + (Function/arrs: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...))) (PolyRow-names: msg-vars _ - (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)) ...)))) + (Function/arrs: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)))) (let ([fcn-string (if name (format "function `~a'" (syntax->datum name)) "function")]) @@ -350,9 +350,9 @@ (list->seteq msg-vars))) (string-append "Type Variables: " (stringify msg-vars) "\n") ""))))))] - [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))) - (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))) - (PolyRow-names: msg-vars _ (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))) + [(or (Poly-names: msg-vars (Function/arrs: msg-doms msg-rngs msg-rests msg-drests kws)) + (PolyDots-names: msg-vars (Function/arrs: msg-doms msg-rngs msg-rests msg-drests kws)) + (PolyRow-names: msg-vars _ (Function/arrs: msg-doms msg-rngs msg-rests msg-drests kws))) (let ([fcn-string (if name (format "function with keywords ~a" (syntax->datum name)) "function with keywords")]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt index ac33893bca..32505178f2 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt @@ -39,7 +39,7 @@ ;; tc/funapp1 currently cannot handle drest arities [(Function: (list (and a (arr: _ _ _ #f _)))) (tc/funapp1 f-stx args-stx a args-res expected)] - [(Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...))) + [(Function/arrs: doms rngs rests (and drests #f) kws #:arrs arrs) (or ;; find the first function where the argument types match (for/first ([dom (in-list doms)] [rng (in-list rngs)] [rest (in-list rests)] [a (in-list arrs)] @@ -58,7 +58,7 @@ dom))))] ;; any kind of dotted polymorphic function without mandatory keyword args [(PolyDots: (list fixed-vars ... dotted-var) - (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...))) + (Function/arrs: doms rngs rests drests (list (Keyword: _ _ #f) ...) #:arrs arrs)) (handle-clauses (doms rngs rests drests arrs) f-stx args-stx ;; only try inference if the argument lengths are appropriate @@ -85,8 +85,7 @@ f-type args-res expected)] ;; regular polymorphic functions without dotted rest, ;; we do not choose any instantiations with mandatory keyword arguments - [(Poly: vars - (Function: (list (and arrs (arr: doms rngs rests #f (list (Keyword: _ _ kw?) ...))) ...))) + [(Poly: vars (Function/arrs: doms rngs rests #f (list (Keyword: _ _ kw?) ...) #:arrs arrs)) (handle-clauses (doms rngs rests kw? arrs) f-stx args-stx ;; only try inference if the argument lengths are appropriate @@ -103,8 +102,7 @@ ;; Row polymorphism. For now we do really dumb inference that only works ;; in very restricted cases, but is probably enough for most cases in ;; the Racket codebase. Eventually this should be extended. - [(PolyRow: vars constraints - (and f-ty (Function: (list (arr: doms _ _ #f _) ...)))) + [(PolyRow: vars constraints (and f-ty (Function/arrs: doms _ _ #f _))) (define (fail) (poly-fail f-stx args-stx f-type args-res #:name (and (identifier? f-stx) f-stx) @@ -157,7 +155,7 @@ [(? needs-resolving?) (tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)] ;; a union of functions can be applied if we can apply all of the elements - [(Union: (and ts (list (Function: _) ...))) + [(Union: (and ts (list (? Function?) ...))) (merge-tc-results (for/list ([fty ts]) (tc/funapp f-stx args-stx fty argtys expected)))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt index 9bdaf8205a..85893b69f3 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt @@ -309,7 +309,7 @@ (let loop ((t t)) (match t [(Mu: _ _) (loop (unfold t))] - [(Function: (list (arr: _ _ _ _ '()) ...)) t] + [(Function/arrs: _ _ _ _ '()) t] [_ #f]))] [_ #f])) @@ -321,7 +321,7 @@ (define (find-matching-arrs formal-arity arities-seen) (match-define (list formal-positionals formal-rest) formal-arity) (match expected-type - [(Function: (and fs (list (arr: argss rets rests drests '()) ...))) + [(Function/arrs: argss rets rests drests '() #:arrs fs) (for/list ([a (in-list argss)] [f (in-list fs)] [r (in-list rests)] [dr (in-list drests)] #:unless (arities-seen-seen-before? arities-seen (list (length a) (or r dr))) #:when (if formal-rest diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt index 012b37fd85..34f91e43da 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt @@ -10,7 +10,7 @@ racket/set (for-syntax racket/base syntax/parse)) -(provide Listof: List: MListof: AnyPoly: AnyPoly-names:) +(provide Listof: List: MListof: AnyPoly: AnyPoly-names: Function/arrs:) (define-match-expander Listof: @@ -87,3 +87,9 @@ (syntax-parse stx [(_ vars dotted-vars body) #'(app unpoly-names vars dotted-vars body)]))) + +(define-match-expander Function/arrs: + (lambda (stx) + (syntax-parse stx + [(_ doms rngs rests drests kws (~optional (~seq #:arrs arrs) #:defaults ([arrs #'_]))) + #'(Function: (and arrs (list (arr: doms rngs rests drests kws) (... ...))))])))