[racket] contracts on functions that take arbitrary keyword arguments

Rackety but otherwise okay

#lang racket

(require rackunit)

(define (make-keyword-procedure-contract kws/c kw-args/c rest/c range/c)
  (define all-contracts (list kws/c kw-args/c rest/c range/c))
  (make-contract 
   #:name `(make-keyword-procedure-contract , at all-contracts)
   #:first-order procedure?
   #:projection (apply make-projection (map contract-projection all-contracts))))

(define (make-projection kws/c kw-args/c rest/c range/c) 
  (lambda (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)
         (define (blame-context s) (blame-add-context blame s #:swap? #t))
         (define kws-check (kws/c (blame-context "the keyword list of")))
         (define kw-args-check (kw-args/c (blame-context "the keywords-arguments list of")))
         (define rest-check (rest/c (blame-context "the arguments list of")))
         (define range-check (range/c (blame-add-context blame "the range of")))
         (call-with-values
          (lambda () (keyword-apply f (kws-check kws) (kw-args-check kw-args) (rest-check rest-args)))
          range-check))))))

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

;; ---------------------------------------------------------------------------------------------------
;; some tests 

(with-handlers ([exn:fail:contract? void])
  (define/contract not-a-function
    (make-keyword-procedure-contract (listof keyword?) list? list? (const #t))
    "not-a-function")
  (error 'not-a-function "control flow should not reach this point"))

(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? void])
  (contracted-apply 5 (list 1 2 3 4))
  (error 'contracted-apply-not-a-function "control flow should not reach this point"))



On Dec 28, 2013, at 7:08 PM, Alexander D. Knauth wrote:

> 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/20131229/be91db4b/attachment-0001.html>