Skip to content

Commit

Permalink
add kw-ctc
Browse files Browse the repository at this point in the history
from syntax-objects/Summer2021#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?
  • Loading branch information
bennn committed Oct 27, 2021
1 parent 5f40873 commit b1ca608
Show file tree
Hide file tree
Showing 5 changed files with 127 additions and 0 deletions.
1 change: 1 addition & 0 deletions index.scrbl
Original file line number Diff line number Diff line change
Expand Up @@ -35,3 +35,4 @@
@include-example{except-in-quiet}
@include-example{dot-underscore}
@include-example{try-catch-finally}
@include-example{kw-ctc}
41 changes: 41 additions & 0 deletions kw-ctc/kw-ctc-test.rkt
Original file line number Diff line number Diff line change
@@ -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)))))

)
42 changes: 42 additions & 0 deletions kw-ctc/kw-ctc.rkt
Original file line number Diff line number Diff line change
@@ -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)))]))

41 changes: 41 additions & 0 deletions kw-ctc/kw-ctc.scrbl
Original file line number Diff line number Diff line change
@@ -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}

}

2 changes: 2 additions & 0 deletions render.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,8 @@

adapted-from
;; Usage @adapted-from[#:what [kind #f] name url]

stxbee2021-issue
)

(require
Expand Down

0 comments on commit b1ca608

Please sign in to comment.