From b1ca608d6f938ac196ed961396cd4794f9d7b738 Mon Sep 17 00:00:00 2001
From: Ben Greenman <benjaminlgreenman@gmail.com>
Date: Mon, 11 Oct 2021 10:41:06 -0400
Subject: [PATCH] add kw-ctc

from https://github.com/syntax-objects/Summer2021/issues/19
cc @dstorrs

I included a pointer to struct-plus-plus. I'm not planning to include
it as another entry because it does a lot at once ... but maybe
it'd go nicely as a big "capstone" kind of example?
---
 index.scrbl            |  1 +
 kw-ctc/kw-ctc-test.rkt | 41 +++++++++++++++++++++++++++++++++++++++++
 kw-ctc/kw-ctc.rkt      | 42 ++++++++++++++++++++++++++++++++++++++++++
 kw-ctc/kw-ctc.scrbl    | 41 +++++++++++++++++++++++++++++++++++++++++
 render.rkt             |  2 ++
 5 files changed, 127 insertions(+)
 create mode 100644 kw-ctc/kw-ctc-test.rkt
 create mode 100644 kw-ctc/kw-ctc.rkt
 create mode 100644 kw-ctc/kw-ctc.scrbl

diff --git a/index.scrbl b/index.scrbl
index 899b742..04ee4f9 100644
--- a/index.scrbl
+++ b/index.scrbl
@@ -35,3 +35,4 @@
 @include-example{except-in-quiet}
 @include-example{dot-underscore}
 @include-example{try-catch-finally}
+@include-example{kw-ctc}
diff --git a/kw-ctc/kw-ctc-test.rkt b/kw-ctc/kw-ctc-test.rkt
new file mode 100644
index 0000000..1b05ee3
--- /dev/null
+++ b/kw-ctc/kw-ctc-test.rkt
@@ -0,0 +1,41 @@
+#lang racket/base
+(module+ test
+  (require rackunit racket/contract syntax-parse-example/kw-ctc/kw-ctc)
+
+  (test-case "ex0"
+    (define ctc0 (kw-ctc ([a] [b symbol?] [(c 0) real?]) list?))
+    (define/contract (f #:a a #:b b #:c [c 0]) ctc0 (list a b c))
+
+    (check-not-exn
+      (lambda ()
+        (f #:a 'A #:b 'B #:c 3.14)))
+
+    (check-not-exn
+      (lambda ()
+        (f #:a "hello" #:b 'B)))
+
+    (check-exn exn:fail:contract?
+      (lambda ()
+        (f #:b 'B)))
+
+    (check-exn exn:fail:contract?
+      (lambda ()
+        (f #:a (void) #:b 42)))
+
+    (check-exn exn:fail:contract?
+      (lambda ()
+        (f #:a (void) #:b 'hello #:c (void)))))
+
+  (test-case "ex1"
+    (define ctc (kw-ctc ([(c 0) real?] [a] [b symbol?]) list?))
+    (define/contract (f #:a a #:b b #:c [c 0]) ctc (list a b c))
+
+    (check-not-exn
+      (lambda ()
+        (f #:a 'A #:b 'B)))
+
+    (check-exn exn:fail:contract?
+      (lambda ()
+        (f #:a (void) #:b 'hello #:c (void)))))
+
+)
diff --git a/kw-ctc/kw-ctc.rkt b/kw-ctc/kw-ctc.rkt
new file mode 100644
index 0000000..07afe1f
--- /dev/null
+++ b/kw-ctc/kw-ctc.rkt
@@ -0,0 +1,42 @@
+#lang racket/base
+(provide kw-ctc)
+(require racket/contract (for-syntax racket/base racket/list syntax/parse syntax/parse/experimental/template))
+
+(begin-for-syntax
+
+  (define (id->keyword stx)
+    (string->keyword (symbol->string (syntax-e stx))))
+
+  (define-syntax-class field
+    (pattern [id:id (~optional cont:expr)]
+             #:with required? #'#t
+             #:with field-contract (template (?? cont any/c))
+             #:with kw #`#,(id->keyword #'id))
+    (pattern [(id:id _:expr) (~optional cont:expr)]
+             #:with required? #'#f
+             #:with field-contract (template (?? cont any/c))
+             #:with kw #`#,(id->keyword #'id)))
+
+  (define field->required?
+    (syntax-parser [f:field (syntax-e #'f.required?)]))
+
+  (define field->kw
+    (syntax-parser [f:field (syntax/loc this-syntax f.kw)]))
+
+  (define field->ctc
+    (syntax-parser [f:field (syntax/loc this-syntax f.field-contract)]))
+
+  (define (field*->contract-spec field*)
+    (apply append (map (lambda (f) (list (field->kw f) (field->ctc f))) field*)))
+)
+
+(define-syntax (kw-ctc stx)
+  (syntax-parse stx
+   [(_ (?dom*:field ...) cod)
+    (define-values [mandatory* optional*]
+      (partition field->required? (syntax-e #'(?dom* ...))))
+    (with-syntax ([mandatory-ctc-spec #`#,(field*->contract-spec mandatory*)]
+                  [optional-ctc-spec #`#,(field*->contract-spec optional*)])
+      (syntax/loc stx
+        (->* mandatory-ctc-spec optional-ctc-spec cod)))]))
+
diff --git a/kw-ctc/kw-ctc.scrbl b/kw-ctc/kw-ctc.scrbl
new file mode 100644
index 0000000..3c634d3
--- /dev/null
+++ b/kw-ctc/kw-ctc.scrbl
@@ -0,0 +1,41 @@
+#lang syntax-parse-example
+@require[
+  (for-label racket/base racket/contract racket/math syntax/parse syntax-parse-example/kw-ctc/kw-ctc)]
+
+@(define kw-ctc-eval
+   (make-base-eval '(require racket/contract racket/math syntax-parse-example/kw-ctc/kw-ctc)))
+
+@title{Generate Contracts for Keyword Functions}
+@stxbee2021["dstorrs" 19]
+@nested[#:style 'inset @emph{Adapted from the
+  @hyperlink["https://docs.racket-lang.org/struct-plus-plus/index.html" @tt{struct-plus-plus}]
+  module, which contains many other interesting macros (@stxbee2021-issue{18}).}]
+
+@; =============================================================================
+
+@defmodule[syntax-parse-example/kw-ctc/kw-ctc]{}
+
+@defform[(kw-ctc (dom-spec ...) cod-spec)
+         #:grammar ([dom-spec [id]
+                              [id ctc-expr]
+                              [(id default)]
+                              [(id default) ctc-expr]]
+                    [cod-spec ctc-expr])]{
+  Shorthand to write contracts for functions that expect only keyword arguments.
+
+  @examples[#:eval kw-ctc-eval
+    (struct pumpkin [name weight color])
+    (define/contract (make-pumpkin #:name name #:weight weight #:color [color "Dark Orange"])
+      (kw-ctc ([name] [weight natural?] [(color _) string?]) pumpkin?)
+      (pumpkin name weight color))
+    (make-pumpkin #:name 'roger #:weight 140)
+    (make-pumpkin #:name #false #:weight 117 #:color "Indigo")
+    (eval:error (make-pumpkin #:weight 999))
+  ]
+
+  Implementation:
+
+  @racketfile{kw-ctc.rkt}
+
+}
+
diff --git a/render.rkt b/render.rkt
index 023f460..5263317 100644
--- a/render.rkt
+++ b/render.rkt
@@ -35,6 +35,8 @@
 
   adapted-from
   ;; Usage @adapted-from[#:what [kind #f] name url]
+
+  stxbee2021-issue
 )
 
 (require