Support definitions of keyword functions in Typed Racket.

Caveats:
 - keyword function definitions do not define static
   bindings, thus limiting optimization opportunities
 - can't use `define:`, `lambda:`, etc with keywords
 - error messages sometimes expose the implementation
 - the optimizer skips most of the generated code for
   keyword functions definitions (user-level code is
   optimized)

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

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)

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)

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)]
   )

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]

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])])

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"

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]

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)]

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]))

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))
 

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)]))
 

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

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

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