Generate contracts for keyword functions

[dstorrs]

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))))]))