Generate contracts for keyword functions #19
Description
The following is a snippet from the struct-plus-plus module, available here: https://docs.racket-lang.org/struct-plus-plus/index.html
It is a template metafunction, meaning a function that can be used inside a macro.
Example
(struct++ person
([name]
[age number?]
[(vegan? #f) boolean?])
#:transparent)
(person++ #:name "alice" #:age 18)
When run, the above code produces:
> (person "alice" 18 #f)
The contract on the person++ function is:
(->* (#:name any/c #:age number?) (#:vegan? boolean?) person?)
Code
(require syntax/parse/experimental/template)
; Fields have an identifier, optionally followed by a contract, optionally followed by
; a wrapper function:
;
; [name] ; a field to store a person's name
; [name string?] ; accept only strings
; [name any/c ~a] ; accept any value, convert it to a string
;
; A default value may be supplied with any of the forms by replacing `name` with
; `(name val)`, e.g.: [(name "bob") string?]
(define-syntax-class field
(pattern (~or id:id
[id:id (~optional (~seq cont:expr (~optional wrap:expr)))])
#:with required? #'#t
#:with field-contract (template (?? cont any/c))
#:with wrapper (template (?? wrap identity))
#:with ctor-arg #`(#,(syntax->keyword #'id) id)
#:with def #''no-default-given)
(pattern [(id:id default-value:expr)
(~optional (~seq cont:expr (~optional wrap:expr)))]
#:with required? #'#f
#:with field-contract (template (?? cont any/c))
#:with wrapper (template (?? wrap identity))
#:with ctor-arg #`(#,(syntax->keyword #'id) [id default-value])
#:with def (template default-value)))
;; Generate the contract for the constructor function. Must handle optional arguments.
;; This would be called something like the following:
;; (make-ctor-contract ((field.required? (field.id field.field-contract)) ... predicate))
;; NB: `predicate` would be something like `person?` but its definition is not shown.
;;
(define-template-metafunction (make-ctor-contract stx)
(define-syntax-class contract-spec
(pattern (required?:boolean (name:id contr:expr))))
;;
(syntax-parse stx
#:datum-literals (make-ctor-contract)
[(make-ctor-contract (item:contract-spec ...+ predicate))
(let-values
([(mandatory optional)
(partition (syntax-parser [(flag _) (syntax-e #'flag)])
(map (syntax-parser [(flag (name contr))
(quasitemplate (flag (#,(syntax->keyword #'name)
contr)))])
(syntax->list #'(item ...))))])
(with-syntax ((((_ (mand-kw mand-contract)) ...) mandatory)
(((_ (opt-kw opt-contract)) ...) optional))
(template (->* ((?@ mand-kw mand-contract) ...)
((?@ opt-kw opt-contract) ...)
predicate))))]))