[racket] contracts on functions that take arbitrary keyword arguments

This is my first try at making something like a make-keyword-procedure- 
contract.  Any suggestions or things I did wrong?
By the way it doesn't seem like a good idea to put separate contracts  
on the kws and kw-args, but that's what I did for now because I don't  
need to check anything about the keywords.  Also, the error messages  
aren't the best.

#lang racket

(require rackunit)

(define ((make-keyword-procedure-contract-proj kws-contract-proj kw- 
args-contract-proj rest-contract-proj range-contract-proj) blame)
   (lambda (f)
     (unless (procedure? f)
       (raise-blame-error blame f
        '(expected: "procedure?" given: "~e") f))
     (make-keyword-procedure
      (lambda (kws kw-args . rest-args)
        (let ([kws-blame (blame-add-context blame "the keyword list  
of" #:swap? #t)]
              [kw-args-blame (blame-add-context blame "the kw- 
arguments list of" #:swap? #t)]
              [rest-args-blame (blame-add-context blame "the arguments  
list of" #:swap? #t)]
              [range-blame (blame-add-context blame "the rage of")])
          (call-with-values (lambda () (keyword-apply f
                                                      ((kws-contract- 
proj kws-blame) kws)
                                                      ((kw-args- 
contract-proj kw-args-blame) kw-args)
                                                      ((rest-contract- 
proj rest-args-blame) rest-args)))
                            (range-contract-proj range-blame)))))))

(define (make-keyword-procedure-contract kws-contract kw-args-contract  
rest-contract range-contract)
   (make-contract #:name `(make-keyword-procedure-contract ,kws- 
contract ,kw-args-contract ,rest-contract ,range-contract)
                  #:first-order (lambda (f) (procedure? f))
                  #:projection (apply make-keyword-procedure-contract- 
proj
                                      (map contract-projection
                                           (list kws-contract kw-args- 
contract
                                                 rest-contract range- 
contract)))))

(define-syntax match?/c
   (syntax-rules ()
     [(match?/c pat)
      (flat-named-contract '(match?/c pat)
                           (lambda (x)
                             (match x
                               [pat #t]
                               [_ #f])))]
     [(match?/c pat #:when condition)
      (flat-named-contract '(match?/c pat #:when condition)
                           (lambda (x)
                             (match x
                               [pat #:when condition #t]
                               [_ #f])))]
     ))


(with-handlers ([exn:fail:contract? (compose1 displayln exn-message)])
   (define/contract not-a-function (make-keyword-procedure-contract  
(listof keyword?) list?
                                                                     
list?
                                                                     
(const #t))
     "not-a-function")
   (void))

(newline)

(define/contract contracted-apply (make-keyword-procedure-contract  
(listof keyword?) list?
                                                                     
(match?/c (list (? procedure? f) arg ... (? list? rest-args)))
                                                                     
(const #t))
   (make-keyword-procedure
    (lambda (kws kw-args f . rest-args)
      (keyword-apply f kws kw-args (apply list* rest-args)))))

(check-equal? (contracted-apply + (list 1 2 3))
               6)

(define (kinetic-energy #:mass m #:velocity v)
   (* 1/2 m (sqr v)))

(check-equal? (contracted-apply kinetic-energy #:mass 2 #:velocity 1  
'())
               1)

(with-handlers ([exn:fail:contract? (compose1 displayln exn-message)])
   (contracted-apply 5 (list 1 2 3 4)))

On Dec 28, 2013, at 4:46 PM, Robby Findler wrote:

> http://docs.racket-lang.org/reference/Building_New_Contract_Combinators.html?q=racketcontract
>
> (But there is a new interface (the old one will continue to work of  
> course) in the git version)
>
> Let me know if you have questions or get stuck and I'll try to  
> improve the docs.
>
> Robby
>
>
> On Sat, Dec 28, 2013 at 3:40 PM, Alexander D. Knauth <alexander at knauth.org 
> > wrote:
> What's the lower-level, projection-based api and how do I use it?
>
> On Dec 28, 2013, at 11:50 AM, Robby Findler wrote:
>
>> I think you probably could make a contract that did what you were  
>> talking about in the first message in this thread, but you cannot  
>> do it with any of the existing contract combinators (->, ->*, case- 
>> >, ->i, etc). You would have to use the lower-level, projection- 
>> based api to make a new combinator.
>>
>> But Matthias's advice is probably a better route.
>>
>> Robby
>>
>>
>> On Sat, Dec 28, 2013 at 1:43 AM, Alexander D. Knauth <alexander at knauth.org 
>> > wrote:
>> The problem isn't with defining the function, the problem is with  
>> making a contract for it.
>>
>> I can define the function fine, I just don't know how to write a  
>> contract for it.  I used make-keyword-procedure to define the  
>> function, but is there something like make-keyword-procedure- 
>> contract?  I could write my own error code, but it would be better  
>> if I could express it as a contract.
>>
>> The actual concrete example is that I'm making my own version of  
>> send that works with method-like procedures.
>>
>> #lang racket
>>
>> (define/contract current-send-object (parameter/c (or/c object? #f))
>>   (make-parameter #f))
>>
>> (define my-send
>>   (make-keyword-procedure
>>    (lambda (kws kw-args object proc . rest-args)
>>      (parameterize ([current-send-object object])
>>        (keyword-apply proc kws kw-args rest-args)))))
>>
>> (define point%
>>   (class object%
>>     (super-new)
>>     (init-field [x 0] [y 0])
>>     (define/public (get-x) x)
>>     (define/public (get-y) y)))
>>
>> (define (get-vector)
>>   (let* ([object (current-send-object)]
>>          [x (send object get-x)]
>>          [y (send object get-y)])
>>     (vector x y)))
>>
>> (define p (new point% [x 3] [y 5]))
>>
>> (require rackunit)
>>
>> (check-equal? (my-send p get-vector)
>>               (vector 3 5))
>>
>> (check-equal? (my-send p (compose vector->list get-vector))
>>               (list 3 5))
>>
>> that way you can define new "methods" without them being specified  
>> by the class, and they're first class functions.  I wanted to be  
>> able to make a contract for my-send (and my-send/apply etc.) that  
>> would check that object is an object and that proc is a procedure,  
>> but still take arbitrary keyword arguments and just pass them on to  
>> proc.
>>
>> On Dec 27, 2013, at 1:03 PM, Matthias Felleisen wrote:
>>
>>>
>>> This is a bit vague. Can you clarify the question with a concrete  
>>> example?
>>>
>>>
>>> On Dec 26, 2013, at 7:45 PM, "Alexander D. Knauth" <alexander at knauth.org 
>>> > wrote:
>>>
>>>> I want to make contracts on some apply-like functions that check  
>>>> some arguments but just passes all the others (including keyword  
>>>> arguments) on to a function (provided as an argument).  If there  
>>>> weren't any keyword arguments, I could use a rest argument to do  
>>>> this, but that wouldn't work with keyword arguments.  Is there a  
>>>> way to do something like a rest argument for keyword-arguments in  
>>>> a contract?____________________
>>>> Racket Users list:
>>>> http://lists.racket-lang.org/users
>>>
>>
>>
>> ____________________
>>   Racket Users list:
>>   http://lists.racket-lang.org/users
>>
>>
>
>

-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20131228/c35ca04c/attachment-0001.html>