From 3b80ae71f9d84abb717f92d16723a8f1f6d27347 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Tue, 24 Mar 2015 22:28:59 -0700
Subject: [PATCH] correct keyword function conversion

Keyword functions are a little tricky. This PR addresses issues
checking the body of kw functions.

Basically, a function with keyword arguments such as inc:

(define (inc x #:n [n 1])
  (+ x n))

actually expands into a more complex function with 3 arguments that
looks something resembling the following:

(define (inc-expanded n* n-given? x)
   (let ([n (if n-given? n* 1)]) (+ x n)))

and calls to inc are converted to match this form:

(inc 42) => (inc-expanded #f #f 42)

(inc 42 #:n 2) => (inc-expanded 2 #t 42)

Note that each optional keyword argument has a boolean flag argument
that signals whether or not the caller provided that keyword argument.

This PR takes advantage of the observation that the value for the n*
argument in inc is only reachable in code when n-given? is #t, and so,
assuming the kw-expansion protocol always only accesses n* if n-given?
is #t, we can actually safely check the body of the function against
the following simple but correct type:

(-> Number Boolean Number Number)

An alternative previous approach expanded the function type into every
possible combination of optional argument and optional argument flag,
but this was prohibitively expensive.
---
 .../typed-racket/rep/type-rep.rkt             |   9 +-
 .../typed-racket/types/kw-types.rkt           | 152 +++++++++---------
 typed-racket-test/fail/gh56.rkt               |   5 +
 3 files changed, 87 insertions(+), 79 deletions(-)
 create mode 100644 typed-racket-test/fail/gh56.rkt

diff --git a/typed-racket-lib/typed-racket/rep/type-rep.rkt b/typed-racket-lib/typed-racket/rep/type-rep.rkt
index 922eb5f3..323b3bea 100644
--- a/typed-racket-lib/typed-racket/rep/type-rep.rkt
+++ b/typed-racket-lib/typed-racket/rep/type-rep.rkt
@@ -462,11 +462,17 @@
   [#:for-each (f) (f ty)])
 
 
+(define (keyword-sorted/c kws)
+  (or (empty? kws)
+      (= (length kws) 1)
+      (apply keyword<? (map Keyword-kw kws))))
+
+
 (def-rep arr ([dom (listof Type?)]
               [rng SomeValues?]
               [rest (or/c #f Type?)]
               [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))]
-              [kws (listof Keyword?)])
+              [kws (and/c (listof Keyword?) keyword-sorted/c)])
   [#:frees
    [#:vars (f)
     (combine-frees
@@ -507,6 +513,7 @@
    (when rest (f rest))
    (for-each f kws)])
 
+
 ;; arities : Listof[arr]
 (def-type Function ([arities (listof arr?)])
   [#:mask mask:procedure]
diff --git a/typed-racket-lib/typed-racket/types/kw-types.rkt b/typed-racket-lib/typed-racket/types/kw-types.rkt
index e6760643..80874092 100644
--- a/typed-racket-lib/typed-racket/types/kw-types.rkt
+++ b/typed-racket-lib/typed-racket/types/kw-types.rkt
@@ -7,71 +7,61 @@
          "../utils/tc-utils.rkt"
          "../base-env/annotate-classes.rkt"
          "tc-result.rkt"
-         racket/list racket/set racket/dict racket/match
+         racket/list racket/set racket/match
          racket/format racket/string
+         racket/dict
          syntax/parse)
 
 ;; 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))
-
+(define (convert kw-ts plain-ts opt-ts rng rest drest split?)
   (when drest
     (int-err "drest passed to kw-convert"))
-
-  (define arities
-    (for/list ([i (in-range (length opt-t))])
-      (make-arr* (append plain-t (take opt-t i))
-                 rng
-                 #:kws kw-t
-                 #:rest rest
-                 #:drest drest)))
   ;; the kw function protocol passes rest args as an explicit list
-  (define rest-type (if rest (-lst rest) empty))
-  (define ts 
-    (flatten
-     (list
-      (for/list ([k (in-list kw-t)])
-        (match k
-          [(Keyword: _ t #t) t]
-          [(Keyword: _ t #f) (list (-opt t) -Boolean)]))
-      plain-t
-      (for/list ([t (in-list opt-t)]) (-opt t))
-      (for/list ([t (in-list opt-t)]) -Boolean)
-      rest-type)))
+  (define rest-type (if rest (list (-lst rest)) empty))
+
   ;; the kw protocol puts the arguments in keyword-sorted order in the
   ;; function header, so we need to sort the types to match
   (define sorted-kws
-    (sort kw-t keyword<? #:key (match-lambda [(Keyword: kw _ _) kw])))
-  (define ts/true
-    (flatten
-     (list
-      (for/list ([k (in-list sorted-kws)])
-        (match k
-          [(Keyword: _ t #t) t]
-          [(Keyword: _ t #f) (list t (-val #t))]))
-      plain-t
-      (for/list ([t (in-list opt-t)]) t)
-      (for/list ([t (in-list opt-t)]) (-val #t))
-      rest-type)))
-  (define ts/false
-    (flatten
-     (list
-      (for/list ([k (in-list sorted-kws)])
-        (match k
-          [(Keyword: _ t #t) t]
-          [(Keyword: _ t #f) (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))
-      rest-type)))
-  (make-Function
-    (if split?
-        (remove-duplicates
-          (list (make-arr* ts/true rng #:drest drest)
-                (make-arr* ts/false rng #:drest drest)))
-        (list (make-arr* ts rng #:rest rest #:drest drest)))))
+    (sort kw-ts (λ (kw1 kw2) (keyword<? (Keyword-kw kw1)
+                                       (Keyword-kw kw2)))))
 
+  (make-Function
+    (cond
+      [(not split?)
+       (define ts 
+         (flatten
+          (list
+           (for/list ([k (in-list sorted-kws)])
+             (match k
+               [(Keyword: _ t #t) t]
+               [(Keyword: _ t #f) (list (-opt t) -Boolean)]))
+           plain-ts
+           (for/list ([t (in-list opt-ts)]) (-opt t))
+           (for/list ([t (in-list opt-ts)]) -Boolean)
+           rest-type)))
+       (list (make-arr* ts rng #:rest rest #:drest drest))]
+      [else
+       ;; The keyword argument types including boolean flags for
+       ;; optional keyword arguments
+       (define kw-args
+         (for/fold ([pos '()])
+                   ([k (in-list (reverse sorted-kws))])
+           (match k
+             ;; mandatory keyword arguments have no extra args
+             [(Keyword: _ t #t) (cons t pos)]
+             ;; we can safely assume 't' and not (-opt t) here
+             ;; because if the keyword is not provided, the value
+             ;; will only appear in dead code (i.e. where the kw-flag arg is #f)
+             ;; within the body of the function
+             [(Keyword: _ t #f) (list* t -Boolean pos)])))
+
+       ;; Add boolean arguments for the optional type flaggs.
+       (define opt-flags (make-list (length opt-ts) -Boolean))
+
+       (list (make-arr* (append kw-args plain-ts opt-ts opt-flags rest-type)
+                        rng
+                        #:drest drest))])))
 
 ;; This is used to fix the props of keyword types.
 ;; TODO: This should also explore deeper into the actual types and remove props in there as well.
@@ -112,7 +102,7 @@
 
 (define (arity-length a)
   (match a
-    [(arr: args result rest drest kws) (length args)]))
+    [(arr: args _ _ _ _) (length args)]))
 
 
 (define (arg-diff a1 a2)
@@ -120,13 +110,14 @@
     [(arr: args _ _ _ _) (drop args (arity-length a1))]))
 
 (define (find-prefixes l)
-  (define l* (sort l < #:key arity-length))
-  (for/fold ([d (list)]) ([e (in-list l*)])
+  (define l* (sort l (λ (arr1 arr2) (< (arity-length arr1)
+                                       (arity-length arr2)))))
+  (for/fold ([d '()]) ([e (in-list l*)])
     (define prefix (for/or ([p (in-dict-keys d)])
                      (and (prefix-of p e) p)))
     (if prefix
         (dict-set d prefix (arg-diff prefix e))
-        (dict-set d e empty))))
+        (dict-set d e null))))
 
 ;; handle-extra-or-missing-kws : (Listof Keyword) LambdaKeywords
 ;;                               -> (Listof Keyword)
@@ -153,14 +144,17 @@
 (define (inner-kw-convert arrs actual-kws split?)
   (define table (find-prefixes arrs))
   (define fns
-    (for/set ([(k v) (in-dict table)])
-      (match k
-        [(arr: mand rng rest drest kws)
-         (define kws* (if actual-kws
-                          (handle-extra-or-missing-kws kws actual-kws)
-                          kws))
-         (convert kws* mand v rng rest drest split?)])))
-  (apply cl->* (set->list fns)))
+    ;; use for/list and remove duplicates afterwards instead of
+    ;; set and set->list to retain determinism
+    (remove-duplicates
+     (for/list ([(k v) (in-dict table)])
+       (match k
+         [(arr: mand rng rest drest kws)
+          (define kws* (if actual-kws
+                           (handle-extra-or-missing-kws kws actual-kws)
+                           kws))
+          (convert kws* mand v rng rest drest split?)]))))
+  (apply cl->* fns))
 
 ;; kw-convert : Type (Option LambdaKeywords) [Boolean] -> Type
 ;; Given an ordinary function type, convert it to a type that matches the keyword
@@ -331,19 +325,21 @@
     [(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]))))
+  (let loop ([ft ft])
+    (match ft
+      [(Function: arrs)
+       (let ([arrs (map (opt-convert-arr required-pos optional-pos) arrs)])
+         (and (andmap values arrs)
+              (make-Function arrs)))]
+      [(Poly-names: names f)
+       (match (loop f)
+         [#f #f]
+         [t (make-Poly names t)])]
+      [(PolyDots-names: names f)
+       (match (loop f)
+         [#f #f]
+         [t (make-PolyDots names t)])]
+      [t t])))
 
 ;; opt-unconvert : Type (Listof Syntax) -> Type
 ;; Given a type for a core optional arg function, unconvert it to a
diff --git a/typed-racket-test/fail/gh56.rkt b/typed-racket-test/fail/gh56.rkt
new file mode 100644
index 00000000..17f40f31
--- /dev/null
+++ b/typed-racket-test/fail/gh56.rkt
@@ -0,0 +1,5 @@
+#lang typed/racket
+
+(: f (Number [#:y Boolean] -> Number))
+(define (f x #:y [y #f] #:z [z 'this-can-be-anything])
+   (if y "y is truthy" x))