diff --git a/collects/syntax/scribblings/define.scrbl b/collects/syntax/scribblings/define.scrbl index 5ff9ec56ad..b513b31cde 100644 --- a/collects/syntax/scribblings/define.scrbl +++ b/collects/syntax/scribblings/define.scrbl @@ -10,7 +10,7 @@ [lambda-id-stx identifier?] [check-context? boolean? #t] - [opt+kws? boolean? #t]) + [opt+kws? boolean? #f]) (values identifier? syntax?)]{ Takes a definition form whose shape is like @racket[define] (though diff --git a/collects/tests/typed-racket/succeed/kw-def.rkt b/collects/tests/typed-racket/succeed/kw-def.rkt new file mode 100644 index 0000000000..959cf36242 --- /dev/null +++ b/collects/tests/typed-racket/succeed/kw-def.rkt @@ -0,0 +1,34 @@ +#lang typed/racket + +(: f (case-> + (Integer [#:k Integer] -> Integer) + (Integer String [#:k Integer] -> Integer))) +(define f + (lambda (x [z 2] #:k [y 1]) (+ x y))) + +(: f2 (case-> + (Integer [#:k Integer] -> Integer) + (Integer String [#:k Integer] -> Integer))) +(define (f2 x [z 2] #:k [y 1]) (+ x y)) + +(f 0) +(f 0 "s") +(f 0 #:k 1) +(f 0 "s" #:k 1) +(f 0 #:k 1 "s") + +(f2 0) +(f2 0 "s") +(f2 0 #:k 1) +(f2 0 "s" #:k 1) +(f2 0 #:k 1 "s") + +(: g (Integer #:k Integer -> Integer)) +(define g + (lambda (x #:k y) (+ x y))) + +(: g2 (Integer #:k Integer -> Integer)) +(define (g2 x #:k y) (+ x y)) + +(g 0 #:k 1) +(g2 0 #:k 1) diff --git a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt index 56b9ee854a..2a7b5340a1 100644 --- a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -4,9 +4,11 @@ (for-syntax scheme/base) (for-template scheme/base)) (require (private type-annotation parse-type) - (base-env prims - base-types-extra - base-env-indexing base-structs) + (except-in + (base-env prims + base-types-extra + base-env-indexing base-structs) + define lambda λ) (typecheck typechecker) (rep type-rep filter-rep object-rep) (rename-in (types utils union convenience abbrev filter-ops) diff --git a/collects/typed-racket/base-env/base-special-env.rkt b/collects/typed-racket/base-env/base-special-env.rkt index 70f18ef091..67962e5c23 100644 --- a/collects/typed-racket/base-env/base-special-env.rkt +++ b/collects/typed-racket/base-env/base-special-env.rkt @@ -133,4 +133,9 @@ ;; from the expansion of `make-temp-file` [(make-template-identifier 'make-temporary-file/proc 'racket/file) (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] + ;; from the (lifted) portion of the expansion of keyword lambdas + [(make-template-identifier 'make-required 'racket/private/kw) + (-> Univ Univ Univ Univ Univ)] + [(make-template-identifier 'missing-kw 'racket/private/kw) + (->* (list Univ) Univ Univ)] ) diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt index 264af9d606..56d1ef5cc8 100644 --- a/collects/typed-racket/base-env/prims.rkt +++ b/collects/typed-racket/base-env/prims.rkt @@ -23,6 +23,9 @@ This file defines two sorts of primitives. All of them are provided into any mod : (rename-out [define-typed-struct define-struct:] [lambda: λ:] + [-lambda lambda] + [-lambda λ] + [-define define] [with-handlers: with-handlers] [define-typed-struct/exec define-struct/exec:] [for/annotation for] @@ -40,6 +43,7 @@ This file defines two sorts of primitives. All of them are provided into any mod syntax/parse racket/syntax racket/base + syntax/define racket/struct-info syntax/struct "../rep/type-rep.rkt" @@ -284,7 +288,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (lambda: stx) (syntax-parse stx [(lambda: formals:annotated-formals . body) - (syntax/loc stx (lambda formals.ann-formals . body))])) + (syntax/loc stx (-lambda formals.ann-formals . body))])) (define-syntax (case-lambda: stx) (syntax-parse stx @@ -848,6 +852,20 @@ 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)))) +;; annotation to help tc-expr pick out keyword functions +(define-syntax (-lambda stx) + (syntax-parse stx + [(_ formals . body) + (define d (datum->syntax stx `(,#'λ ,#'formals . ,#'body) + stx stx)) + (syntax-property d 'kw-lambda #t)])) + +;; do this ourselves so that we don't get the static bindings, +;; which are harder to typecheck +(define-syntax (-define stx) + (define-values (i b) (normalize-definition stx #'-lambda #t #t)) + (datum->syntax stx `(,#'define ,i ,b) stx stx)) + (define-syntax (with-asserts stx) (define-syntax-class with-asserts-clause [pattern [x:id] diff --git a/collects/typed-racket/optimizer/optimizer.rkt b/collects/typed-racket/optimizer/optimizer.rkt index caf276a1f8..66bd56b2c7 100644 --- a/collects/typed-racket/optimizer/optimizer.rkt +++ b/collects/typed-racket/optimizer/optimizer.rkt @@ -20,6 +20,14 @@ (define-syntax-class opt-expr* #:commit #:literal-sets (kernel-literals) + + ;; can't optimize the body of this code because it isn't typechecked + (pattern ((~and op (~literal let-values)) + ([(i:id) e-rhs:expr]) e-body:expr ...) + #:when (syntax-property this-syntax 'kw-lambda) + #:with opt-rhs ((optimize) #'e-rhs) + #:with opt (quasisyntax/loc/origin this-syntax #'op + (op ([(i) opt-rhs]) e-body ...))) ;; interesting cases, where something is optimized (pattern e:dead-code-opt-expr #:with opt #'e.opt) @@ -49,7 +57,7 @@ (cons (car l) (map (optimize) (cdr l))))) #'([formals e ...] ...)) - #:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...))) + #:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...))) (pattern ((~and op (~or (~literal let-values) (~literal letrec-values))) ([ids e-rhs:expr] ...) e-body:expr ...) #:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...)) @@ -88,7 +96,9 @@ [e:expr #:when (and (not (syntax-property #'e 'typechecker:ignore)) (not (syntax-property #'e 'typechecker:ignore-some)) - (not (syntax-property #'e 'typechecker:with-handlers))) + (not (syntax-property #'e 'typechecker:with-handlers)) + #; + (not (syntax-property #'e 'kw-lambda))) #:with e*:opt-expr #'e #'e*.opt] [e:expr #'e])]) diff --git a/collects/typed-racket/private/with-types.rkt b/collects/typed-racket/private/with-types.rkt index 8a9af72efd..d19108134b 100644 --- a/collects/typed-racket/private/with-types.rkt +++ b/collects/typed-racket/private/with-types.rkt @@ -2,10 +2,10 @@ (require racket/require (for-template - (except-in racket/base for for* with-handlers) + (except-in racket/base for for* with-handlers lambda λ define) "../base-env/prims.rkt" (prefix-in c: (combine-in racket/contract/region racket/contract/base))) - "../base-env/extra-procs.rkt" (except-in "../base-env/prims.rkt" with-handlers) + "../base-env/extra-procs.rkt" (except-in "../base-env/prims.rkt" with-handlers λ lambda define) "../tc-setup.rkt" syntax/parse racket/match unstable/sequence "../base-env/base-types-extra.rkt" diff --git a/collects/typed-racket/tc-setup.rkt b/collects/typed-racket/tc-setup.rkt index 8acb457a88..320ba3c502 100644 --- a/collects/typed-racket/tc-setup.rkt +++ b/collects/typed-racket/tc-setup.rkt @@ -37,7 +37,7 @@ (set-box! typed-context? #t) ;(start-timing (syntax-property stx 'enclosing-module-name)) (with-handlers - ([(λ (e) (and (exn:fail? e) (not (exn:fail:syntax? e)) (not (exn:fail:filesystem? e)))) + (#;[(λ (e) (and (exn:fail? e) (not (exn:fail:syntax? e)) (not (exn:fail:filesystem? e)))) (λ (e) (tc-error "Internal Typed Racket Error : ~a" e))]) (parameterize (;; enable fancy printing? [custom-printer #t] diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt index 91f330910d..678a1aac7e 100644 --- a/collects/typed-racket/typecheck/tc-expr-unit.rkt +++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt @@ -4,7 +4,7 @@ (require (rename-in "../utils/utils.rkt" [private private-in]) racket/match (prefix-in - scheme/contract) "signatures.rkt" "tc-envops.rkt" "tc-metafunctions.rkt" "tc-subst.rkt" - "check-below.rkt" "tc-funapp.rkt" "tc-app-helper.rkt" + "check-below.rkt" "tc-funapp.rkt" "tc-app-helper.rkt" "../types/kw-types.rkt" (types utils convenience union subtype remove-intersect type-table filter-ops) (private-in parse-type type-annotation) (rep type-rep) @@ -338,6 +338,19 @@ (let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _)))) (#%plain-app _ _ args ...)))) (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)] + ;; kw function def + [(let-values ([(_) fun]) + . body) + #:when (syntax-property form 'kw-lambda) + (match expected + [(tc-result1: (and f (Function: _))) + ;(printf ">>> ~a\n" f) + ;(printf ">>>\t ~a\n" (kw-convert f #:split #t)) + (tc-expr/check/type #'fun (kw-convert f #:split #t))] + [(tc-result1: (Poly-names: names (and f (Function: _)))) + (tc-expr/check/type #'fun (make-Poly names (kw-convert f #:split #t)))] + [(tc-result1: _) (tc-error/expr "Keyword functions must have function type, given ~a" expected)]) + expected] ;; let [(let-values ([(name ...) expr] ...) . body) (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)] diff --git a/collects/typed-racket/typecheck/tc-lambda-unit.rkt b/collects/typed-racket/typecheck/tc-lambda-unit.rkt index 07fac85c29..5bd1a3039d 100644 --- a/collects/typed-racket/typecheck/tc-lambda-unit.rkt +++ b/collects/typed-racket/typecheck/tc-lambda-unit.rkt @@ -275,6 +275,10 @@ (and (check-below (ret t true-filter) expected) t) t)) +(define (plambda-prop stx) + (define d (syntax-property stx 'typechecker:plambda)) + (and d (car (flatten d)))) + ;; tc/plambda syntax syntax-list syntax-list type -> Poly ;; formals and bodies must by syntax-lists (define/cond-contract (tc/plambda form formals bodies expected) @@ -290,7 +294,7 @@ [_ (int-err "expected not an appropriate tc-result: ~a" expected)])) (match expected [(tc-result1: (and t (Poly-names: ns expected*))) - (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) + (let* ([tvars (let ([p (plambda-prop form)]) (when (and (pair? p) (eq? '... (car (last p)))) (tc-error "Expected a polymorphic function without ..., but given function had ...")) @@ -303,7 +307,7 @@ [(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*))) (let-values ([(tvars dotted) - (let ([p (syntax-property form 'typechecker:plambda)]) + (let ([p (plambda-prop form)]) (if p (match (map syntax-e (syntax->list p)) [(list var ... dvar '...) @@ -316,7 +320,7 @@ (maybe-loop form formals bodies (ret expected*)))) t)] [#f - (match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda))) + (match (map syntax-e (syntax->list (plambda-prop form))) [(list tvars ... dotted-var '...) (let* ([ty (extend-indexes dotted-var (extend-tvars tvars @@ -337,7 +341,7 @@ ;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic ;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result (define (tc/lambda/internal form formals bodies expected) - (if (or (syntax-property form 'typechecker:plambda) + (if (or (plambda-prop form) (match expected [(tc-result1: t) (or (Poly? t) (PolyDots? t))] [_ #f])) diff --git a/collects/typed-racket/typed-racket.rkt b/collects/typed-racket/typed-racket.rkt index 0ace76fb55..5ee8001760 100644 --- a/collects/typed-racket/typed-racket.rkt +++ b/collects/typed-racket/typed-racket.rkt @@ -8,10 +8,7 @@ "utils/any-wrap.rkt" unstable/contract) (provide (rename-out [module-begin #%module-begin] - [top-interaction #%top-interaction] - [#%plain-lambda lambda] - [#%app #%app] - [require require]) + [top-interaction #%top-interaction]) with-type (for-syntax do-standard-inits)) diff --git a/collects/typed-racket/types/kw-types.rkt b/collects/typed-racket/types/kw-types.rkt index c75059c717..243bccb53a 100644 --- a/collects/typed-racket/types/kw-types.rkt +++ b/collects/typed-racket/types/kw-types.rkt @@ -5,7 +5,7 @@ racket/list racket/dict racket/set racket/match) ;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type] [Option Type] -> (values Type Type) -(define (convert kw-t plain-t opt-t rng rest drest) +(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)) (define arities (for/list ([i (length opt-t)]) @@ -17,14 +17,43 @@ (define ts (flatten (list - mand-kw-t + (for/list ([k mand-kw-t]) + (match k + [(Keyword: _ t _) t])) (for/list ([k (in-list opt-kw-t)]) (match k [(Keyword: _ t _) (list (-opt t) -Boolean)])) plain-t (for/list ([t (in-list opt-t)]) (-opt t)) - (for/list ([t (in-list opt-t)]) -Boolean)))) - (make-Function (list (make-arr* ts rng #:rest rest #:drest drest)))) + (for/list ([t (in-list opt-t)]) -Boolean)))) + (define ts/true + (flatten + (list + (for/list ([k mand-kw-t]) + (match k + [(Keyword: _ t _) t])) + (for/list ([k (in-list opt-kw-t)]) + (match k + [(Keyword: _ t _) (list t (-val #t))])) + plain-t + (for/list ([t (in-list opt-t)]) t) + (for/list ([t (in-list opt-t)]) (-val #t))))) + (define ts/false + (flatten + (list + (for/list ([k mand-kw-t]) + (match k + [(Keyword: _ t _) t])) + (for/list ([k (in-list opt-kw-t)]) + (match k + [(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))))) + (if split? + (make-Function (list (make-arr* ts/true rng #:rest rest #:drest drest) + (make-arr* ts/false rng #:rest rest #:drest drest))) + (make-Function (list (make-arr* ts rng #:rest rest #:drest drest))))) (define (prefix-of a b) (define (drest-equal? a b) @@ -64,7 +93,7 @@ (dict-set d prefix (arg-diff prefix e)) (dict-set d e empty)))) -(define (kw-convert ft) +(define (kw-convert ft #:split [split? #f]) (match ft [(Function: arrs) (define table (find-prefixes arrs)) @@ -72,7 +101,7 @@ (for/list ([(k v) (in-dict table)]) (match k [(arr: mand rng rest drest kws) - (convert kws mand v rng rest drest)]))) + (convert kws mand v rng rest drest split?)]))) (apply cl->* fns)] [(Poly-names: names (Function: arrs)) (define table (find-prefixes arrs)) @@ -80,7 +109,7 @@ (for/list ([(k v) (in-dict table)]) (match k [(arr: mand rng rest drest kws) - (convert kws mand v rng rest drest)]))) + (convert kws mand v rng rest drest split?)]))) (make-Poly names (apply cl->* fns))] [_ (int-err 'kw-convert "non-function type" ft)])) diff --git a/collects/typed-racket/utils/stxclass-util.rkt b/collects/typed-racket/utils/stxclass-util.rkt index a3efaec137..ac24833197 100644 --- a/collects/typed-racket/utils/stxclass-util.rkt +++ b/collects/typed-racket/utils/stxclass-util.rkt @@ -23,7 +23,7 @@ [#,i #:declare #,i pat #'#,get-i])))])) (define (atom? v) - (or (number? v) (string? v) (boolean? v) (symbol? v) (keyword? v) (char? v) (bytes? v) (regexp? v))) + (or (number? v) (string? v) (boolean? v) (symbol? v) (char? v) (bytes? v) (regexp? v))) (define-syntax-class (3d pred) (pattern s diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt index 860ebfa9ac..31edd0df0d 100644 --- a/collects/typed/racket/base.rkt +++ b/collects/typed/racket/base.rkt @@ -1,7 +1,7 @@ #lang typed-racket/minimal -(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) - (basics #%module-begin #%top-interaction lambda #%app)) +(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers define λ lambda define-struct for for*)) + (basics #%module-begin #%top-interaction)) (require typed-racket/base-env/extra-procs (except-in typed-racket/base-env/prims diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt index 6dd51f2f5b..f038bdb8eb 100644 --- a/collects/typed/scheme/base.rkt +++ b/collects/typed/scheme/base.rkt @@ -1,7 +1,7 @@ #lang typed-racket/minimal -(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) - (basics #%module-begin #%top-interaction lambda #%app)) +(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers define λ lambda define-struct for for*)) + (basics #%module-begin #%top-interaction)) (require typed-racket/base-env/extra-procs (rename-in