From 6580635e354303f6c424d79b80a9bc9c6f51eb95 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 24 Mar 2013 13:38:33 -0700 Subject: [PATCH] Redo the calculation of opt-lambda expansion. Closes PR 13661. Closes PR 13584. original commit: c910252fdff4d18343fc9b47334b4fd4423ae794 --- .../typed-racket/base-env/prims.rkt | 55 +++++++++--- .../typed-racket/typecheck/tc-expr-unit.rkt | 23 ++++- .../typed-racket/types/kw-types.rkt | 88 +++++++++++++------ .../tests/typed-racket/succeed/pr13584.rkt | 13 +++ .../typed-racket/unit-tests/all-tests.rkt | 2 + .../unit-tests/keyword-expansion-test.rkt | 84 ++++++++++++++++++ .../unit-tests/typecheck-tests.rkt | 5 ++ 7 files changed, 226 insertions(+), 44 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/succeed/pr13584.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/keyword-expansion-test.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 49ffa20f..861230c0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -1115,24 +1115,51 @@ This file defines two sorts of primitives. All of them are provided into any mod (quasisyntax/loc stx (#,l/c k.ann-name . body))])) (values (mk #'let/cc) (mk #'let/ec)))) + +(begin-for-syntax + (define-syntax-class optional-arg + (pattern name:id #:attr value #f) + (pattern (name:id value:expr))) + (define-splicing-syntax-class lambda-args + #:attributes (required-pos + optional-pos + optional-kws + required-kws) + (pattern (~seq (~or pos:optional-arg (~seq kw:keyword key:optional-arg)) ...) + #:attr optional-pos (length (filter values (attribute pos.value))) + #:attr required-pos (- (length (filter values (attribute pos.name))) + (attribute optional-pos)) + #:attr optional-kws + (for/list ((kw (attribute kw)) + (kw-value (attribute key.value)) + #:when kw-value) + kw) + #:attr required-kws (remove* (attribute optional-kws) (attribute kw))))) + + ;; annotation to help tc-expr pick out keyword functions (define-syntax (-lambda stx) (syntax-parse stx [(_ formals . body) - (define-values (has-kw? has-opt?) - (syntax-parse #'formals - ((~or (~and rest:id (~bind ((args 1) null))) - (args ...) - (args ...+ . rest:id)) - (define arg-list (syntax->list #'(args ...))) - (values - (ormap keyword? (map syntax-e arg-list)) - (ormap syntax->list arg-list))))) - (opt-lambda-property - (kw-lambda-property - (syntax/loc stx (λ formals . body)) - has-kw?) - has-opt?)])) + (define d (syntax/loc stx (λ formals . body))) + (syntax-parse #'formals + [(~or (~and (args:lambda-args) (~bind (rest #f))) + (args:lambda-args . rest:id)) + (define kw-property + (> (+ (length (attribute args.required-kws)) + (length (attribute args.optional-kws))) + 0)) + (define opt-property + (and (> (attribute args.optional-pos) 0) + (list + (attribute args.required-pos) + (attribute args.optional-pos)))) + (syntax-property + (syntax-property d 'kw-lambda kw-property) + 'opt-lambda opt-property)] + ;; This is an error and will be caught by the real lambda + [_ d])])) + ;; do this ourselves so that we don't get the static bindings, ;; which are harder to typecheck diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 62a77a96..97ddceca 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -263,10 +263,9 @@ (let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _)))) (#%plain-app _ _ args ...)))) (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)] - ;; kw/opt function def - [(let-values ([(_) fun]) - . body) - #:when (or (kw-lambda-property form) (opt-lambda-property form)) + ;; kw function def + [(let-values ([(_) fun]) . body) + #:when (syntax-property form 'kw-lambda) (match expected [(tc-result1: (and f (or (Function: _) (Poly: _ (Function: _))))) @@ -274,6 +273,22 @@ [(or (tc-results: _) (tc-any-results:)) (tc-error/expr "Keyword functions must have function type, given ~a" expected)]) expected] + ;; opt function def + [(let-values ([(f) fun]) . body) + #:when (syntax-property form 'opt-lambda) + (define conv-type + (match expected + [(tc-result1: fun-type) + (match-define (list required-pos optional-pos) + (syntax-property form 'opt-lambda)) + (opt-convert fun-type required-pos optional-pos)] + [_ #f])) + (match-define (tc-result1: returned-fun-type) + (if conv-type + (tc-expr/check/type #'fun conv-type) + (tc-expr #'fun))) + (with-lexical-env/extend (list #'f) (list returned-fun-type) + (tc-exprs/check (syntax->list #'body) expected))] ;; let [(let-values ([(name ...) expr] ...) . body) (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt index e57acca2..7afe0c3f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt @@ -2,9 +2,10 @@ (require "abbrev.rkt" "../rep/type-rep.rkt" "union.rkt" "../utils/tc-utils.rkt" - racket/list racket/dict racket/match) + racket/list racket/set racket/dict racket/match) -;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type] [Option Type] -> (values Type Type) +;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type] +;; [Option Type] [Option (Pair Type symbol)] boolean -> Type (define (convert kw-t plain-t opt-t rng rest drest split?) (define-values (mand-kw-t opt-kw-t) (partition (match-lambda [(Keyword: _ _ m) m]) kw-t)) @@ -57,13 +58,13 @@ [(Keyword: _ t _) (list (-val #f) (-val #f))])) plain-t (for/list ([t (in-list opt-t)]) (-val #f)) - (for/list ([t (in-list opt-t)]) (-val #f)) - ;; the kw function protocol passes rest args as an explicit list - (if rest (-lst rest) empty)))) - (if split? - (make-Function (list (make-arr* ts/true rng) - (make-arr* ts/false rng))) - (make-Function (list (make-arr* ts rng))))) + (for/list ([t (in-list opt-t)]) (-val #f))))) + (make-Function + (if split? + (remove-duplicates + (list (make-arr* ts/true rng #:rest rest #:drest drest) + (make-arr* ts/false rng #:rest rest #:drest drest))) + (list (make-arr* ts rng #:rest rest #:drest drest))))) (define (prefix-of a b) (define (rest-equal? a b) @@ -110,24 +111,59 @@ (dict-set d prefix (arg-diff prefix e)) (dict-set d e empty)))) +(define (inner-kw-convert arrs split?) + (define table (find-prefixes arrs)) + (define fns + (for/set ([(k v) (in-dict table)]) + (match k + [(arr: mand rng rest drest kws) + (convert kws mand v rng rest drest split?)]))) + (apply cl->* (set->list fns))) + (define (kw-convert ft #:split [split? #f]) (match ft [(Function: arrs) - (define table (find-prefixes arrs)) - (define fns - (for/list ([(k v) (in-dict table)]) - (match k - [(arr: mand rng rest drest kws) - (convert kws mand v rng rest drest split?)]))) - (apply cl->* fns)] - [(Poly-names: names (Function: arrs)) - (define table (find-prefixes arrs)) - (define fns - (for/list ([(k v) (in-dict table)]) - (match k - [(arr: mand rng rest drest kws) - (convert kws mand v rng rest drest split?)]))) - (make-Poly names (apply cl->* fns))] - [_ (int-err "kw-convert: non-function type ~a" ft)])) + (inner-kw-convert arrs split?)] + [(Poly-names: names f) + (make-Poly names (kw-convert f #:split split?))] + [(PolyDots-names: names f) + (make-PolyDots names (kw-convert f #:split split?))])) -(provide kw-convert) +(define ((opt-convert-arr required-pos optional-pos) arr) + (match arr + [(arr: args result #f #f '()) + (define num-args (length args)) + (and (>= num-args required-pos) + (<= num-args (+ required-pos optional-pos)) + (let* ([required-args (take args required-pos)] + [opt-args (drop args required-pos)] + [missing-opt-args (- (+ required-pos optional-pos) num-args)] + [present-flags (map (λ (t) (-val #t)) opt-args)] + [missing-args (make-list missing-opt-args (-val #f))]) + (make-arr (append required-args + opt-args + missing-args + present-flags + missing-args) + result + #f + #f + '())))] + [(arr: args result _ _ _) #f])) + +(define (opt-convert ft required-pos optional-pos) + (let/ec exit + (let loop ((ft ft)) + (match ft + [(Function: arrs) + (let ((arrs (map (opt-convert-arr required-pos optional-pos) arrs))) + (if (andmap values arrs) + (make-Function arrs) + (exit #f)))] + [(Poly-names: names f) + (make-Poly names (loop f))] + [(PolyDots-names: names f) + (make-PolyDots names (loop f))] + [t t])))) + +(provide kw-convert opt-convert) diff --git a/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/succeed/pr13584.rkt b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/succeed/pr13584.rkt new file mode 100644 index 00000000..5b83a176 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/succeed/pr13584.rkt @@ -0,0 +1,13 @@ +#lang typed/racket + +(: f (case-> + (-> Boolean) + (Input-Port -> Boolean) + (Bytes -> Boolean))) + +(define (f (p #f)) + (cond ((input-port? p) #t) + ((bytes? p) #f) + (else #f))) + +(assert (call-with-input-bytes #"port" f)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/all-tests.rkt index ea308f5f..083eff83 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/all-tests.rkt @@ -11,6 +11,7 @@ "subst-tests.rkt" ;; pass "infer-tests.rkt" ;; pass "type-annotation-test.rkt" ;; pass + "keyword-expansion-test.rkt" ;;pass "module-tests.rkt" ;; pass "contract-tests.rkt" @@ -38,6 +39,7 @@ module-tests fv-tests contract-tests + keyword-tests ;; this uses dynamic require because the file fails to compile when there's a test failure (λ () ((dynamic-require special 'typecheck-special-tests))))]) (f)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/keyword-expansion-test.rkt b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/keyword-expansion-test.rkt new file mode 100644 index 00000000..3b17311d --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/keyword-expansion-test.rkt @@ -0,0 +1,84 @@ +#lang racket/base + +(require "test-utils.rkt" + (rep type-rep) + (types utils kw-types abbrev numeric-tower) + racket/match racket/set + rackunit) +(provide keyword-tests) + +(define-syntax-rule (t arg expected) + (begin + (test-equal? (format "~a" '(arg expected)) + (kw-convert arg) + expected))) + +(define (extract-arrs t) + (match t + [(Function: arrs) (apply set arrs)] + [t t])) + +(define-syntax-rule (t-opt ((req-arg ...) (opt-arg ...)) expected) + (let () + (test-equal? (format "~a" '(opt-convert (->opt req-arg ... (opt-arg ...) result) expected)) + (extract-arrs + (opt-convert (->opt req-arg ... (opt-arg ...) result) + (length (list 'req-arg ...)) + (length (list 'opt-arg ...)))) + (extract-arrs expected)))) + + +(define flag -Boolean) +(define true (-val #t)) +(define false (-val #f)) +(define result (-val 'result)) +(define one (-val 'one)) +(define two (-val 'two)) +(define three (-val 'three)) +(define four (-val 'four)) + +(define (keyword-tests) + (test-suite "Tests for keyword expansion" + + [t (-> result) (-> result)] + [t (-> one result) + (-> one result)] + [t (-> one two three four result) + (-> one two three four result)] + [t (->opt (one) result) + (-> (-opt one) flag result)] + [t (->opt (one two) result) + (-> (-opt one) (-opt two) flag flag result)] + [t (->opt one (two three) result) + (-> one (-opt two) (-opt three) flag flag result)] + + [t-opt (() ()) (-> result)] + [t-opt ((one) ()) + (-> one result)] + [t-opt (() (one)) + (cl->* + (-> one true result) + (-> false false result))] + [t-opt ((one two three four) ()) + (-> one two three four result)] + [t-opt (() (one)) + (cl->* + (-> one true result) + (-> false false result))] + [t-opt (() (one two)) + (cl->* + (-> one two true true result) + (-> one false true false result) + (-> false false false false result))] + [t-opt ((one) (two three)) + (cl->* + (-> one two three true true result) + (-> one two false true false result) + (-> one false false false false result))] + + + + + )) + +(define-go keyword-tests) diff --git a/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/typecheck-tests.rkt index 2ed17077..66519ccc 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -1647,6 +1647,11 @@ [w 'result] [(x) (add1 "hello")]) (->* (list) Univ (-val 'result) : -true-lfilter)] + + [tc-e + (opt-lambda: ((x : Symbol 'a)) x) + #:ret (ret (t:-> -Symbol -Symbol) (-FS -top -bot)) + #:expected (ret (t:-> -Symbol -Symbol) (-FS -top -bot))] ) (test-suite "check-type tests"