From 003ac9b33880b032bcae8d8e28f5cf737c1dac94 Mon Sep 17 00:00:00 2001
From: Alex Knauth <alexander@knauth.org>
Date: Wed, 7 Oct 2020 01:11:02 -0400
Subject: [PATCH]  add keyword-apply/dict to racket/dict  (#2592)

* add keyword-apply/dict to racket/dict
* add history note
---
 .../scribblings/reference/dicts.scrbl         | 51 +++++++++-
 .../tests/racket/keyword-apply-dict.rkt       | 98 +++++++++++++++++++
 racket/collects/racket/dict.rkt               |  3 +
 .../racket/private/keyword-apply-dict.rkt     | 61 ++++++++++++
 4 files changed, 212 insertions(+), 1 deletion(-)
 create mode 100644 pkgs/racket-test/tests/racket/keyword-apply-dict.rkt
 create mode 100644 racket/collects/racket/private/keyword-apply-dict.rkt

diff --git a/pkgs/racket-doc/scribblings/reference/dicts.scrbl b/pkgs/racket-doc/scribblings/reference/dicts.scrbl
index f0472b8ab9..eb0b84e1ed 100644
--- a/pkgs/racket-doc/scribblings/reference/dicts.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/dicts.scrbl
@@ -2,7 +2,8 @@
 @(require "mz.rkt" (for-label racket/generic))
 
 @(define dict-eval (make-base-eval))
-@examples[#:hidden #:eval dict-eval (require racket/dict racket/generic racket/contract)]
+@examples[#:hidden #:eval dict-eval
+          (require racket/dict racket/generic racket/contract racket/string)]
 
 @title[#:tag "dicts"]{Dictionaries}
 
@@ -1014,4 +1015,52 @@ See also @racket[define-custom-hash-types].
 
 }
 
+@section{Passing keyword arguments in dictionaries}
+
+@defproc[
+ (keyword-apply/dict [proc procedure?]
+                     [kw-dict dict?] ; (dict/c keyword? any/c)
+                     [pos-arg any/c] ...
+                     [pos-args (listof any/c)]
+                     [#:<kw> kw-arg any/c] ...)
+ any]{
+Applies the @racket[proc] using the positional arguments
+from @racket[(list* pos-arg ... pos-args)], and the keyword
+arguments from @racket[kw-dict] in addition to the directly
+supplied keyword arguments in the @racket[#:<kw> kw-arg]
+ sequence.
+
+All the keys in @racket[kw-dict] must be keywords.
+The keywords in the @racket[kw-dict] do not have to be
+sorted. However, the keywords in @racket[kw-dict] and the
+directly supplied @racket[#:<kw>] keywords must not overlap.
+The given @racket[proc] must accept all of the keywords in
+@racket[kw-dict] plus the @racket[#:<kw>]s.
+
+@examples[
+#:eval dict-eval
+(define (sundae #:ice-cream [ice-cream '("vanilla")]
+                #:toppings [toppings '("brownie-bits")]
+                #:sprinkles [sprinkles "chocolate"]
+                #:syrup [syrup "caramel"])
+  (format "A sundae with ~a ice cream, ~a, ~a sprinkles, and ~a syrup."
+          (string-join ice-cream #:before-last " and ")
+          (string-join toppings #:before-last " and ")
+          sprinkles
+          syrup))
+(keyword-apply/dict sundae '((#:ice-cream . ("chocolate"))) '())
+(keyword-apply/dict sundae
+                    (hash '#:toppings '("cookie-dough")
+                          '#:sprinkles "rainbow"
+                          '#:syrup "chocolate")
+                    '())
+(keyword-apply/dict sundae
+                    #:sprinkles "rainbow"
+                    (hash '#:toppings '("cookie-dough")
+                          '#:syrup "chocolate")
+                    '())
+]
+@history[#:added "7.9"]}
+
+
 @close-eval[dict-eval]
diff --git a/pkgs/racket-test/tests/racket/keyword-apply-dict.rkt b/pkgs/racket-test/tests/racket/keyword-apply-dict.rkt
new file mode 100644
index 0000000000..23e29d837f
--- /dev/null
+++ b/pkgs/racket-test/tests/racket/keyword-apply-dict.rkt
@@ -0,0 +1,98 @@
+#lang racket/base
+(require rackunit racket/dict racket/list racket/string racket/math)
+
+(define (sorted-assoc-dict alst) (sort alst keyword<? #:key car))
+(define (unsorted-assoc-dict alst)
+  (cond [(or (empty? alst) (empty? (rest alst))) alst]
+        [else
+         (define shf (shuffle alst))
+         (if (apply keyword<? (map car shf)) (reverse shf) shf)]))
+(define assoc-dicts (list sorted-assoc-dict unsorted-assoc-dict))
+
+(define ihash-dict make-immutable-hash)
+(define ihasheqv-dict make-immutable-hasheqv)
+(define ihasheq-dict make-immutable-hasheq)
+(define ihash-dicts (list ihash-dict ihasheqv-dict ihasheq-dict))
+
+(define mhash-dict make-hash)
+(define mhasheqv-dict make-hasheqv)
+(define mhasheq-dict make-hasheq)
+(define mhash-dicts (list mhash-dict mhasheqv-dict mhasheq-dict))
+
+(define dicts (append assoc-dicts ihash-dicts mhash-dicts))
+
+(for ([d (in-list dicts)])
+  (define (name x)
+    (format "keyword-apply/dict with ~a: ~a" (object-name d) x))
+
+  (test-case (name "go")
+    (define (go #:mode mode target) (list target mode))
+    (check-equal? (keyword-apply/dict go (d '((#:mode . fast))) '("super.rkt"))
+                  '("super.rkt" fast)))
+
+  (test-case (name "sundae")
+    (define (sundae #:ice-cream [ice-cream '("vanilla")]
+                    #:toppings [toppings '("brownie-bits")]
+                    #:sprinkles [sprinkles "chocolate"]
+                    #:syrup [syrup "caramel"])
+      (format "A sundae with ~a ice cream, ~a, ~a sprinkles, and ~a syrup."
+              (string-join ice-cream #:before-last " and ")
+              (string-join toppings #:before-last " and ")
+              sprinkles
+              syrup))
+    (check-equal? (keyword-apply/dict sundae
+                                      (d '((#:ice-cream . ("chocolate"))))
+                                      '())
+                  "A sundae with chocolate ice cream, brownie-bits, chocolate sprinkles, and caramel syrup.")
+    (check-equal? (keyword-apply/dict sundae
+                                      (d '((#:toppings . ("cookie-dough"))
+                                           (#:sprinkles . "rainbow")
+                                           (#:syrup . "chocolate")))
+                                      '())
+                  "A sundae with vanilla ice cream, cookie-dough, rainbow sprinkles, and chocolate syrup.")
+    (check-equal? (keyword-apply/dict sundae
+                                      #:sprinkles "rainbow"
+                                      (d '((#:toppings . ("cookie-dough"))
+                                           (#:syrup . "chocolate")))
+                                      '())
+                  "A sundae with vanilla ice cream, cookie-dough, rainbow sprinkles, and chocolate syrup."))
+
+  (test-case (name "f mand y opt z")
+    (define (f x #:y y #:z [z 10])
+      (list x y z))
+
+    (check-equal? (keyword-apply/dict f (d '((#:y . 2))) '(1)) '(1 2 10))
+    (check-equal? (keyword-apply/dict f (d '((#:y . 2) (#:z . 3))) '(1)) '(1 2 3))
+    (check-equal? (keyword-apply/dict f #:z 7 (d '((#:y . 2))) '(1)) '(1 2 7)))
+
+  (test-case (name "dotted-h")
+    (define (dotted-h x #:y [y 12])
+      (list x y))
+
+    (check-equal? (keyword-apply/dict dotted-h (d '()) (list 2)) '(2 12))
+    (check-equal? (keyword-apply/dict dotted-h (d '((#:y . 8))) (list 3)) '(3 8))
+    (check-equal? (keyword-apply/dict dotted-h (d '((#:y . 14))) '(g)) '(g 14)))
+
+  (test-case (name "f mand a b c")
+    (define (f #:a a #:b b #:c c d e f) (list a b c d e f))
+
+    (check-equal? (keyword-apply/dict
+                   f
+                   (d '((#:b . "b") (#:c . "c") (#:a . "a")))
+                   '("d" "e" "f"))
+                  (list "a" "b" "c" "d" "e" "f")))
+
+  (test-case (name "kinetic-energy")
+    (define (kinetic-energy #:mass m #:velocity v)
+      (* 1/2 m (sqr v)))
+    (check-equal? (keyword-apply/dict kinetic-energy '((#:mass . 2) (#:velocity . 1)) '())
+                  1)
+    (check-equal? (keyword-apply/dict kinetic-energy '((#:mass . 5) (#:velocity . 3)) '())
+                  (+ 22 1/2)))
+
+  (test-case (name "error keyword duplicated")
+    (check-exn
+     #rx"keyword-apply/dict: keyword duplicated in dict and direct keyword arguments: '#:color"
+     (λ ()
+       (keyword-apply/dict void (d '((#:color . "green"))) #:color "red" '())))))
+
diff --git a/racket/collects/racket/dict.rkt b/racket/collects/racket/dict.rkt
index afeee17c2f..0ae5d79c4d 100644
--- a/racket/collects/racket/dict.rkt
+++ b/racket/collects/racket/dict.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/contract/base
          "private/dict.rkt"
+         "private/keyword-apply-dict.rkt"
          "private/custom-hash.rkt")
 
 (define (dict-implements/c . syms)
@@ -287,6 +288,8 @@
          in-dict-values
          in-dict-pairs
 
+         keyword-apply/dict
+
          dict-key-contract
          dict-value-contract
          dict-iter-contract)
diff --git a/racket/collects/racket/private/keyword-apply-dict.rkt b/racket/collects/racket/private/keyword-apply-dict.rkt
new file mode 100644
index 0000000000..8baaf8a508
--- /dev/null
+++ b/racket/collects/racket/private/keyword-apply-dict.rkt
@@ -0,0 +1,61 @@
+#lang racket/base
+
+(provide keyword-apply/dict)
+
+(require "dict.rkt")
+
+;; Proc [Dictof Kw Any] Any ... [Listof Any] -> Any
+(define keyword-apply/dict
+  (let ()
+    ;; keys : [Dictof Kw Any] -> [Listof Kw]
+    ;; Produces the sorted list of keys
+    (define (keys kws)
+      (unless (dict? kws)
+        (raise-argument-error 'keyword-apply/dict "dict" kws))
+      (define ks (dict-keys kws))
+      (unless (andmap keyword? ks)
+        (raise-argument-error 'keyword-apply/dict
+                              "dict with keyword keys"
+                              kws))
+      (sort ks keyword<?))
+
+    ;; vals : [Dictof Kw Any] [Listof Kw] -> Any
+    ;; Produces the list of vals in the same order as ks
+    (define (vals kws ks)
+      (for/list ([k (in-list ks)]) (dict-ref kws k)))
+
+    ;; check-dup : [Listof Kw] [Listof Kw] -> Void
+    (define (check-dup ks1 ks2)
+      (for ([k1 (in-list ks1)] #:when (memq k1 ks2))
+        (raise-mismatch-error
+         'keyword-apply/dict
+         "keyword duplicated in dict and direct keyword arguments: "
+         k1)))
+
+    ;; Proc [Dictof Kw Any] Any ... [Listof Any] -> Any
+    ;; Used when keyword-apply/dict itself isn't used with keyword arguments
+    (define keyword-apply/dict
+      (case-lambda
+        [(f kws args)
+         (define ks (keys kws))
+         (keyword-apply f ks (vals kws ks) args)]
+        [(f kws arg . rst)
+         (define ks (keys kws))
+         (apply keyword-apply f ks (vals kws ks) arg rst)]))
+
+    ;; [Listof Kw] [Listof Any] Proc [Dictof Kw Any] Any ... [Listof Any] -> Any
+    ;; Used when keyword-apply/dict itself is passed keyword arguments
+    ;; Direct keywords are in ks1, dict is kws2
+    (define kw-proc-keyword-apply/dict
+      (case-lambda
+        [(ks1 vs1 f kws2 args)
+         (define ks2 (keys kws2))
+         (check-dup ks1 ks2)
+         (keyword-apply keyword-apply ks1 vs1 f ks2 (vals kws2 ks2) args '())]
+        [(ks1 vs1 f kws2 arg . rst)
+         (define ks2 (keys kws2))
+         (check-dup ks1 ks2)
+         (keyword-apply keyword-apply ks1 vs1 f ks2 (vals kws2 ks2) arg rst)]))
+
+    (make-keyword-procedure kw-proc-keyword-apply/dict keyword-apply/dict)))
+