From 78a124bfffd67c98c001018cda21cbc94b5c8381 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Wed, 15 Aug 2012 23:59:14 -0700 Subject: [PATCH] Moved keyword special cases out of tc-app.rkt. original commit: c2ab21c5a56bb157a8129fd94b7c599600d53083 --- .../typed-racket/typecheck/signatures.rkt | 3 + collects/typed-racket/typecheck/tc-app.rkt | 115 +-------------- .../typecheck/tc-app/tc-app-keywords.rkt | 132 ++++++++++++++++++ .../typed-racket/typecheck/typechecker.rkt | 3 +- 4 files changed, 139 insertions(+), 114 deletions(-) create mode 100644 collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index a2bbcc7c..d7a64010 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -43,6 +43,9 @@ (define-signature tc-app-values^ ([cond-contracted tc/app-values (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) +(define-signature tc-app-keywords^ + ([cond-contracted tc/app-keywords (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) + (define-signature tc-apply^ ([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)])) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index fe40af5f..a8fabd84 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -27,7 +27,7 @@ (only-in racket/private/class-internal do-make-object) (only-in syntax/location module-name-fixup))) -(import tc-expr^ tc-lambda^ tc-let^ tc-apply^ +(import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-keywords^ tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^) (export tc-app^) @@ -78,87 +78,6 @@ [(_ _) (ret -Boolean)])) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Keywords - -(define (tc-keywords/internal arity kws kw-args error?) - (match arity - [(arr: dom rng rest #f ktys) - ;; assumes that everything is in sorted order - (let loop ([actual-kws kws] - [actuals (map tc-expr/t (syntax->list kw-args))] - [formals ktys]) - (match* (actual-kws formals) - [('() '()) - (void)] - [(_ '()) - (if error? - (tc-error/expr #:return (ret (Un)) - "Unexpected keyword argument ~a" (car actual-kws)) - #f)] - [('() (cons fst rst)) - (match fst - [(Keyword: k _ #t) - (if error? - (tc-error/expr #:return (ret (Un)) - "Missing keyword argument ~a" k) - #f)] - [_ (loop actual-kws actuals rst)])] - [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) - (cond [(eq? k k*) ;; we have a match - (if (subtype (car actuals) t) - ;; success - (loop kws-rest (cdr actuals) form-rest) - ;; failure - (and error? - (tc-error/delayed - "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" - t (car actuals) k) - (loop kws-rest (cdr actuals) form-rest)))] - [req? ;; this keyword argument was required - (if error? - (begin (tc-error/delayed "Missing keyword argument ~a" k*) - (loop kws-rest (cdr actuals) form-rest)) - #f)] - [else ;; otherwise, ignore this formal param, and continue - (loop actual-kws actuals form-rest)])]))])) - -(define (tc-keywords form arities kws kw-args pos-args expected) - (match arities - [(list (and a (arr: dom rng rest #f ktys))) - (tc-keywords/internal a kws kw-args #t) - (tc/funapp (car (syntax-e form)) kw-args - (ret (make-Function (list (make-arr* dom rng #:rest rest)))) - (map tc-expr (syntax->list pos-args)) expected)] - [(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...) - (let ([new-arities - (for/list ([a (in-list arities)] - ;; find all the arities where the keywords match - #:when (tc-keywords/internal a kws kw-args #f)) - (match a - [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))]) - (if (null? new-arities) - (domain-mismatches - (car (syntax-e form)) (cdr (syntax-e form)) - arities doms rests drests rngs - (map tc-expr (syntax->list pos-args)) - #f #f #:expected expected - #:return (or expected (ret (Un))) - #:msg-thunk - (lambda (dom) - (string-append "No function domains matched in function application:\n" - dom))) - (tc/funapp (car (syntax-e form)) kw-args - (ret (make-Function new-arities)) - (map tc-expr (syntax->list pos-args)) expected)))])) - -(define (type->list t) - (match t - [(Pair: (Value: (? keyword? k)) b) - (cons k (type->list b))] - [(Value: '()) null] - [_ (int-err "bad value in type->list: ~a" t)])) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Objects @@ -269,6 +188,7 @@ (tc/app-list form expected) (tc/app-apply form expected) (tc/app-values form expected) + (tc/app-keywords form expected) (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote not false? list @@ -318,37 +238,6 @@ (match (single-value #'arg) [(tc-result1: t (FilterSet: f+ f-) _) (ret -Boolean (make-FilterSet f- f+))])] - ;; special case for keywords - [(#%plain-app - (#%plain-app cpce s-kp fn kpe kws num) - kw-list - (#%plain-app list . kw-arg-list) - . pos-args) - #:declare cpce (id-from 'checked-procedure-check-and-extract 'racket/private/kw) - #:declare s-kp (id-from 'struct:keyword-procedure 'racket/private/kw) - #:declare kpe (id-from 'keyword-procedure-extract 'racket/private/kw) - (match (tc-expr #'fn) - [(tc-result1: - (Poly: vars - (Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals)))))) - (=> fail) - (unless (null? (fv/list kw-formals)) - (fail)) - (match (map single-value (syntax->list #'pos-args)) - [(list (tc-result1: argtys-t) ...) - (let* ([subst (infer vars null argtys-t dom rng - (and expected (tc-results->values expected)))]) - (unless subst (fail)) - (tc-keywords form (list (subst-all subst ar)) - (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] - [(tc-result1: (Function: arities)) - (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] - [(tc-result1: (Poly: _ (Function: _))) - (tc-error/expr #:return (ret (Un)) - "Inference for polymorphic keyword functions not supported")] - [(tc-result1: t) - (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals) #:fail-unless expected #f diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt new file mode 100644 index 00000000..114cc853 --- /dev/null +++ b/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt @@ -0,0 +1,132 @@ + +#lang racket/unit + +(require (rename-in "../../utils/utils.rkt" [infer r:infer]) + syntax/parse racket/match + (typecheck signatures tc-app-helper tc-funapp tc-metafunctions) + (types abbrev utils union substitute subtype) + (rep type-rep) + (utils tc-utils) + (r:infer infer) + + (for-template racket/base)) + + +(import tc-expr^) +(export tc-app-keywords^) + +(define (tc/app-keywords form expected) + (syntax-parse form + #:literals (#%plain-app list) + [(#%plain-app op:special-op args ...) #f] + [(#%plain-app + (#%plain-app cpce s-kp fn kpe kws num) + kw-list + (#%plain-app list . kw-arg-list) + . pos-args) + #:declare cpce (id-from 'checked-procedure-check-and-extract 'racket/private/kw) + #:declare s-kp (id-from 'struct:keyword-procedure 'racket/private/kw) + #:declare kpe (id-from 'keyword-procedure-extract 'racket/private/kw) + (match (tc-expr #'fn) + [(tc-result1: + (Poly: vars + (Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals)))))) + (=> fail) + (unless (null? (fv/list kw-formals)) + (fail)) + (match (map single-value (syntax->list #'pos-args)) + [(list (tc-result1: argtys-t) ...) + (let* ([subst (infer vars null argtys-t dom rng + (and expected (tc-results->values expected)))]) + (unless subst (fail)) + (tc-keywords form (list (subst-all subst ar)) + (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] + [(tc-result1: (Function: arities)) + (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] + [(tc-result1: (Poly: _ (Function: _))) + (tc-error/expr #:return (ret (Un)) + "Inference for polymorphic keyword functions not supported")] + [(tc-result1: t) + (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] + [_ #f])) + +(define (tc-keywords/internal arity kws kw-args error?) + (match arity + [(arr: dom rng rest #f ktys) + ;; assumes that everything is in sorted order + (let loop ([actual-kws kws] + [actuals (map tc-expr/t (syntax->list kw-args))] + [formals ktys]) + (match* (actual-kws formals) + [('() '()) + (void)] + [(_ '()) + (if error? + (tc-error/expr #:return (ret (Un)) + "Unexpected keyword argument ~a" (car actual-kws)) + #f)] + [('() (cons fst rst)) + (match fst + [(Keyword: k _ #t) + (if error? + (tc-error/expr #:return (ret (Un)) + "Missing keyword argument ~a" k) + #f)] + [_ (loop actual-kws actuals rst)])] + [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) + (cond [(eq? k k*) ;; we have a match + (if (subtype (car actuals) t) + ;; success + (loop kws-rest (cdr actuals) form-rest) + ;; failure + (and error? + (tc-error/delayed + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + t (car actuals) k) + (loop kws-rest (cdr actuals) form-rest)))] + [req? ;; this keyword argument was required + (if error? + (begin (tc-error/delayed "Missing keyword argument ~a" k*) + (loop kws-rest (cdr actuals) form-rest)) + #f)] + [else ;; otherwise, ignore this formal param, and continue + (loop actual-kws actuals form-rest)])]))])) + +(define (tc-keywords form arities kws kw-args pos-args expected) + (match arities + [(list (and a (arr: dom rng rest #f ktys))) + (tc-keywords/internal a kws kw-args #t) + (tc/funapp (car (syntax-e form)) kw-args + (ret (make-Function (list (make-arr* dom rng #:rest rest)))) + (map tc-expr (syntax->list pos-args)) expected)] + [(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...) + (let ([new-arities + (for/list ([a (in-list arities)] + ;; find all the arities where the keywords match + #:when (tc-keywords/internal a kws kw-args #f)) + (match a + [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))]) + (if (null? new-arities) + (domain-mismatches + (car (syntax-e form)) (cdr (syntax-e form)) + arities doms rests drests rngs + (map tc-expr (syntax->list pos-args)) + #f #f #:expected expected + #:return (or expected (ret (Un))) + #:msg-thunk + (lambda (dom) + (string-append "No function domains matched in function application:\n" + dom))) + (tc/funapp (car (syntax-e form)) kw-args + (ret (make-Function new-arities)) + (map tc-expr (syntax->list pos-args)) expected)))])) + +(define (type->list t) + (match t + [(Pair: (Value: (? keyword? k)) b) + (cons k (type->list b))] + [(Value: '()) null] + [_ (int-err "bad value in type->list: ~a" t)])) + + diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index 6c581aa4..ac00248d 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -8,6 +8,7 @@ "signatures.rkt" "tc-app/tc-app-apply.rkt" "tc-app/tc-app-hetero.rkt" + "tc-app/tc-app-keywords.rkt" "tc-app/tc-app-list.rkt" "tc-app/tc-app-values.rkt" "signatures.rkt" @@ -19,4 +20,4 @@ (define-values/invoke-unit/infer (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@ - tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@)) + tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@ tc-app-keywords@))