<html><body style="word-wrap: break-word; -webkit-nbsp-mode: space; -webkit-line-break: after-white-space; "><div>This is my first try at making something like a make-keyword-procedure-contract. Any suggestions or things I did wrong? </div><div>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. </div><div><br></div><div><div><font class="Apple-style-span" face="'Courier New'">#lang racket</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(require rackunit)</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define ((make-keyword-procedure-contract-proj kws-contract-proj kw-args-contract-proj rest-contract-proj range-contract-proj) blame)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (lambda (f)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (unless (procedure? f)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (raise-blame-error blame f</font></div><div><font class="Apple-style-span" face="'Courier New'"> '(expected: "procedure?" given: "~e") f))</font></div><div><font class="Apple-style-span" face="'Courier New'"> (make-keyword-procedure</font></div><div><font class="Apple-style-span" face="'Courier New'"> (lambda (kws kw-args . rest-args)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (let ([kws-blame (blame-add-context blame "the keyword list of" #:swap? #t)]</font></div><div><font class="Apple-style-span" face="'Courier New'"> [kw-args-blame (blame-add-context blame "the kw-arguments list of" #:swap? #t)]</font></div><div><font class="Apple-style-span" face="'Courier New'"> [rest-args-blame (blame-add-context blame "the arguments list of" #:swap? #t)]</font></div><div><font class="Apple-style-span" face="'Courier New'"> [range-blame (blame-add-context blame "the rage of")])</font></div><div><font class="Apple-style-span" face="'Courier New'"> (call-with-values (lambda () (keyword-apply f</font></div><div><font class="Apple-style-span" face="'Courier New'"> ((kws-contract-proj kws-blame) kws)</font></div><div><font class="Apple-style-span" face="'Courier New'"> ((kw-args-contract-proj kw-args-blame) kw-args)</font></div><div><font class="Apple-style-span" face="'Courier New'"> ((rest-contract-proj rest-args-blame) rest-args)))</font></div><div><font class="Apple-style-span" face="'Courier New'"> (range-contract-proj range-blame)))))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define (make-keyword-procedure-contract kws-contract kw-args-contract rest-contract range-contract)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (make-contract #:name `(make-keyword-procedure-contract ,kws-contract ,kw-args-contract ,rest-contract ,range-contract)</font></div><div><font class="Apple-style-span" face="'Courier New'"> #:first-order (lambda (f) (procedure? f))</font></div><div><font class="Apple-style-span" face="'Courier New'"> #:projection (apply make-keyword-procedure-contract-proj</font></div><div><font class="Apple-style-span" face="'Courier New'"> (map contract-projection</font></div><div><font class="Apple-style-span" face="'Courier New'"> (list kws-contract kw-args-contract</font></div><div><font class="Apple-style-span" face="'Courier New'"> rest-contract range-contract)))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define-syntax match?/c</font></div><div><font class="Apple-style-span" face="'Courier New'"> (syntax-rules ()</font></div><div><font class="Apple-style-span" face="'Courier New'"> [(match?/c pat)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (flat-named-contract '(match?/c pat)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (lambda (x)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (match x</font></div><div><font class="Apple-style-span" face="'Courier New'"> [pat #t]</font></div><div><font class="Apple-style-span" face="'Courier New'"> [_ #f])))]</font></div><div><font class="Apple-style-span" face="'Courier New'"> [(match?/c pat #:when condition)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (flat-named-contract '(match?/c pat #:when condition)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (lambda (x)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (match x</font></div><div><font class="Apple-style-span" face="'Courier New'"> [pat #:when condition #t]</font></div><div><font class="Apple-style-span" face="'Courier New'"> [_ #f])))]</font></div><div><font class="Apple-style-span" face="'Courier New'"> ))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(with-handlers ([exn:fail:contract? (compose1 displayln exn-message)])</font></div><div><font class="Apple-style-span" face="'Courier New'"> (define/contract not-a-function (make-keyword-procedure-contract (listof keyword?) list?</font></div><div><font class="Apple-style-span" face="'Courier New'"> list?</font></div><div><font class="Apple-style-span" face="'Courier New'"> (const #t))</font></div><div><font class="Apple-style-span" face="'Courier New'"> "not-a-function")</font></div><div><font class="Apple-style-span" face="'Courier New'"> (void))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(newline)</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define/contract contracted-apply (make-keyword-procedure-contract (listof keyword?) list?</font></div><div><font class="Apple-style-span" face="'Courier New'"> (match?/c (list (? procedure? f) arg ... (? list? rest-args)))</font></div><div><font class="Apple-style-span" face="'Courier New'"> (const #t))</font></div><div><font class="Apple-style-span" face="'Courier New'"> (make-keyword-procedure</font></div><div><font class="Apple-style-span" face="'Courier New'"> (lambda (kws kw-args f . rest-args)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (keyword-apply f kws kw-args (apply list* rest-args)))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(check-equal? (contracted-apply + (list 1 2 3))</font></div><div><font class="Apple-style-span" face="'Courier New'"> 6)</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define (kinetic-energy #:mass m #:velocity v)</font></div><div><font class="Apple-style-span" face="'Courier New'"> (* 1/2 m (sqr v)))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(check-equal? (contracted-apply kinetic-energy #:mass 2 #:velocity 1 '())</font></div><div><font class="Apple-style-span" face="'Courier New'"> 1)</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(with-handlers ([exn:fail:contract? (compose1 displayln exn-message)])</font></div><div><font class="Apple-style-span" face="'Courier New'"> (contracted-apply 5 (list 1 2 3 4)))</font></div></div><br><div><div>On Dec 28, 2013, at 4:46 PM, Robby Findler wrote:</div><br class="Apple-interchange-newline"><blockquote type="cite"><div dir="ltr"><a href="http://docs.racket-lang.org/reference/Building_New_Contract_Combinators.html?q=racketcontract">http://docs.racket-lang.org/reference/Building_New_Contract_Combinators.html?q=racketcontract</a><br><div> <br></div><div>(But there is a new interface (the old one will continue to work of course) in the git version)</div><div><br></div><div>Let me know if you have questions or get stuck and I'll try to improve the docs.</div> <div><br></div><div>Robby</div></div><div class="gmail_extra"><br><br><div class="gmail_quote">On Sat, Dec 28, 2013 at 3:40 PM, Alexander D. Knauth <span dir="ltr"><<a href="mailto:alexander@knauth.org" target="_blank">alexander@knauth.org</a>></span> wrote:<br> <blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex"><div style="word-wrap:break-word"><div>What's the lower-level, projection-based api and how do I use it? </div><div> <div class="h5"><br><div><div>On Dec 28, 2013, at 11:50 AM, Robby Findler wrote:</div><br><blockquote type="cite"><div dir="ltr">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.<div> <br></div><div>But Matthias's advice is probably a better route.<br><div><br>Robby</div></div></div><div class="gmail_extra"><br><br><div class="gmail_quote">On Sat, Dec 28, 2013 at 1:43 AM, Alexander D. Knauth <span dir="ltr"><<a href="mailto:alexander@knauth.org" target="_blank">alexander@knauth.org</a>></span> wrote:<br> <blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex"><div style="word-wrap:break-word"><div>The problem isn't with defining the function, the problem is with making a contract for it. </div> <div><br></div><div>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. </div> <div><br></div><div>The actual concrete example is that I'm making my own version of send that works with method-like procedures. </div><div><br></div><div><span style="font-family:'Courier New'">#lang racket</span></div> <div><span style="font-family:'Courier New'"><br></span></div><div><span style="font-family:'Courier New'">(define/contract current-send-object (parameter/c (or/c object? #f))</span></div><div><font face="'Courier New'"> (make-parameter #f))</font></div> <div><font face="'Courier New'"><br></font></div><div><font face="'Courier New'"><div style="font-family:Helvetica"><font face="'Courier New'">(define my-send</font></div><div style="font-family:Helvetica"> <font face="'Courier New'"> (make-keyword-procedure</font></div><div style="font-family:Helvetica"><font face="'Courier New'"> (lambda (kws kw-args object proc . rest-args)</font></div><div style="font-family:Helvetica"> <font face="'Courier New'"> (parameterize ([current-send-object object])</font></div><div style="font-family:Helvetica"><font face="'Courier New'"> (keyword-apply proc kws kw-args rest-args)))))</font></div> </font></div><div><font face="'Courier New'"><br></font></div><div><font face="'Courier New'">(define point%</font></div><div><font face="'Courier New'"> (class object%</font></div><div><font face="'Courier New'"> (super-new)</font></div> <div><font face="'Courier New'"> (init-field [x 0] [y 0])</font></div><div><font face="'Courier New'"> (define/public (get-x) x)</font></div><div><font face="'Courier New'"> (define/public (get-y) y)</font><span style="font-family:'Courier New'">))</span></div> <div><font face="'Courier New'"><br></font></div><div><font face="'Courier New'">(define (get-vector)</font></div><div><font face="'Courier New'"> (let* ([object (current-send-object)]</font></div> <div><font face="'Courier New'"> [x (send object get-x)]</font></div><div><font face="'Courier New'"> [y (send object get-y)])</font></div><div><font face="'Courier New'"> (vector x y)))</font></div> <div><font face="'Courier New'"><br></font></div><div><font face="'Courier New'">(define p (new point% [x 3] [y 5]))</font></div><div><font face="'Courier New'"><br></font></div><div><font face="'Courier New'">(require rackunit)</font></div> <div><font face="'Courier New'"><br></font></div><div><font face="'Courier New'">(check-equal? (my-send p get-vector)</font></div><div><font face="'Courier New'"> (vector 3 5))</font></div> <div><font face="'Courier New'"><br></font></div><div><font face="'Courier New'">(check-equal? (my-send p (compose vector->list get-vector))</font></div><div><font face="'Courier New'"> (list 3 5))</font></div> <div><font face="'Courier New'"><br></font></div><div>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. </div> <div><br><div><div>On Dec 27, 2013, at 1:03 PM, Matthias Felleisen wrote:</div><br><blockquote type="cite"><div><br>This is a bit vague. Can you clarify the question with a concrete example? <br><br><br>On Dec 26, 2013, at 7:45 PM, "Alexander D. Knauth" <<a href="mailto:alexander@knauth.org" target="_blank">alexander@knauth.org</a>> wrote:<br> <br><blockquote type="cite">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?____________________<br> </blockquote><blockquote type="cite">Racket Users list:<br></blockquote><blockquote type="cite"><a href="http://lists.racket-lang.org/users" target="_blank">http://lists.racket-lang.org/users</a><br></blockquote><br></div> </blockquote></div><br></div></div><br>____________________<br> Racket Users list:<br> <a href="http://lists.racket-lang.org/users" target="_blank">http://lists.racket-lang.org/users</a><br> <br></blockquote></div><br> </div></blockquote></div><br></div></div></div></blockquote></div><br></div></blockquote></div><br></body></html>