Hi Kevin, This is interesting! A number of people have wanted conveniences around `keyword-apply` and accepting the same keywords as some other function. (The trouble is, different people have different ideas of what those conveniences should be.)
To start with, I had a few small suggestions about the code you sent: - `keyword-apply/filter` doesn't need to be a macro, and your macro should use `fn` rather than `h`; - the second result of `procedure-keywords` can be `#f` if the given procedure accepts all keywords; - `for/lists` might be more convenient than `for/fold`; - I think some of the cases in `filter/kw` get the filtering backwards; - keywords can be `quote`-ed as values, so you don't need so many symbol-to-string-to-keyword conversions; - using `set!` this way will cause lots of problems; - there's no need for `list->vector` in `get-kw-val`; and - in `def`, it might be better to use syntax parameters than to break hygiene. You may know this, but all keyword-accepting functions in Racket are effectively implemented with `make-keyword-procedure`: the variants of `lambda` and `define` that use `kw-formals` are macros that expand to more primitive versions that don't know about keywords. The macros also do some optimization where possible. For inspiration, you might be interested in the implementation in https://github.com/racket/racket/blob/master/racket/collects/racket/private/kw.rkt For fun, I wrote a version that illustrates some of these suggestions and and tries to do more work at compile-time. Be warned that it is not thoroughly tested! I'm pasting it below, and I've also put it up as a Gist at https://gist.github.com/LiberalArtist/292b6e99421bc76315110a59c0ce2b0d -Philip #lang racket ;; License: Apache-2 (provide kw-pass-through-lambda local-keyword-apply local-kw-lst local-kw-val-lst (contract-out [keyword-apply/filter (-> procedure? (listof keyword?) list? list? any)])) (module+ test (require rackunit) (define (h #:c c . x) (list c x)) (define g (kw-pass-through-lambda (#:c [c 0] . args) (list c (local-keyword-apply h args)))) (define f (kw-pass-through-lambda (n p #:a [a 0] #:b [b 0] . ns) (list local-kw-lst local-kw-val-lst a b n p ns (local-keyword-apply g ns)))) (check-equal? (f 2 3 4 5 #:a 42 #:c 52) '((#:a #:c) (42 52) 42 0 2 3 (4 5) (52 (52 (4 5))))) ;; My implementation of "filtering" keywords has a different result, ;; but maybe I don't understand what you were trying to do. ;; Your version did this: ;; (check-exn #rx"procedure: h\n given keyword: #:z" ;; (λ () (f 2 3 4 5 #:z 42 #:c 52))) ;; Mine does this instead: (check-equal? (f 2 3 4 5 #:z 42 #:c 52) '((#:c #:z) (52 42) 0 0 2 3 (4 5) (52 (52 (4 5)))))) ;; potential further extensions: ;; - make keyword-apply/filter and local-keyword-apply ;; accept extra keyword and by-position args like keyword-apply ;; - implement a define version of kw-pass-through-lambda ;; - various performance optimizations (require syntax/parse/define racket/stxparam (for-syntax syntax/parse/lib/function-header racket/list racket/match racket/sequence syntax/transformer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; runtime support (define (keyword-apply/filter proc kw-lst kw-val-lst by-pos-args) ;; like keyword-apply, but skips keywords that aren't allowed (define-values [required-kws allowed-kws] (procedure-keywords proc)) (match allowed-kws [#f ;; accepts all keywords (keyword-apply proc kw-lst kw-val-lst by-pos-args)] ['() ;; accepts no keywords (apply proc by-pos-args)] [_ (for/lists [kw-lst* kw-val-lst* #:result (keyword-apply proc kw-lst* kw-val-lst* by-pos-args)] ([kw (in-list kw-lst)] [val (in-list kw-val-lst)] #:when (memq kw allowed-kws)) (values kw val))])) (define (kw-arg-ref kw kw-lst kw-val-lst [fail-thunk ;; we'll use procedure-reduce-keyword-arity ;; to avoid getting here when required kws are missing (λ () (error 'kw-arg-ref "shouldn't get here"))]) (or (for/first ([this-kw (in-list kw-lst)] [val (in-list kw-val-lst)] #:break (keyword<? kw this-kw) #:when (eq? kw this-kw)) val) (fail-thunk))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; syntax layer (define-for-syntax (stxparam-uninitialized stx) (raise-syntax-error #f "only allowed inside kw-pass-through-lambda" stx)) (define-syntax-parameter local-kw-lst stxparam-uninitialized) (define-syntax-parameter local-kw-val-lst stxparam-uninitialized) (define-syntax-parameter local-keyword-apply stxparam-uninitialized) (define-simple-macro (lambda/name kw-formals #:name name:id body ...+) ;; a simple helper (w/ minimal cheking) ;; to give a function a good inferred name (let ([name (λ kw-formals body ...)]) name)) (define-for-syntax (check-required-not-after-optional names kws defaults) ;; required by-position arguments must come before ;; optional by-position arguments: ;; if any don't, return the first offending identifier (let*-values ([{names defaults} ;; ignore kw args (for/lists [names defaults] ([n (in-list names)] [d (in-list defaults)] [kw (in-list kws)] #:unless kw) (values n d))] [{names defaults} ;; drop leading required args (let loop ([names names] [defaults defaults]) (match defaults [(cons #f defaults) (loop (cdr names) defaults)] [_ (values names defaults)]))]) (for/first ([n (in-list names)] [d (in-list defaults)] #:unless d) n))) (define-syntax-parser kw-pass-through-lambda [(_ (arg:formal ... . (~or* rest-arg-name:id ())) body ...+) #:fail-when (check-duplicate-identifier (syntax->list #'(arg.name ... (~? rest-arg-name)))) "duplicate argument name" #:fail-when (check-duplicates (syntax->list #'((~? arg.kw) ...)) #:key syntax-e eq?) "duplicate keyword for argument" #:fail-when (check-required-not-after-optional (attribute arg.name) (attribute arg.kw) (attribute arg.default)) "default-value expression missing" ;; the error message λ gives ;; sort formals #:with ([by-pos-name:id (~optional by-pos-default:expr)] ...) (for/list ([stx (in-syntax #'([arg.name (~? arg.default)] ...))] [kw? (in-list (attribute arg.kw))] #:unless kw?) stx) #:with ((~alt [opt-kw:keyword opt-kw-name:id opt-kw-default:expr] [reqired-kw:keyword reqired-kw-name:id]) ...) #'((~? [arg.kw arg.name (~? arg.default)]) ...) #:with (by-pos-formal ...) #'((~? [by-pos-name by-pos-default] by-pos-name) ...) #:with inferred-name:id (or (syntax-local-name) #'kw-pass-through-procedure) #:with (core-arg-name:id ...) #'(by-pos-name ... reqired-kw-name ... opt-kw-name ... (~? rest-arg-name)) #'(let* ([core ;; w/ only required args (lambda/name (kw-lst kw-val-lst core-arg-name ...) #:name inferred-name (define (the-local-keyword-apply proc by-pos-args) (keyword-apply/filter proc kw-lst kw-val-lst by-pos-args)) (syntax-parameterize ([local-kw-lst (make-variable-like-transformer #'kw-lst)] [local-kw-val-lst (make-variable-like-transformer #'kw-val-lst)] [local-keyword-apply (make-variable-like-transformer #'the-local-keyword-apply)]) body ...))] [explicit-kws-proc ;; version that handles finding kw arg values and calls core ;; all by-pos args must be present (lambda/name (kw-lst kw-val-lst by-pos-name ... (~? rest-arg-name)) #:name inferred-name (let ([reqired-kw-name (kw-arg-ref 'reqired-kw kw-lst kw-val-lst)] ...) (let* ([opt-kw-name (kw-arg-ref 'opt-kw kw-lst kw-val-lst (λ () opt-kw-default))] ...) (core kw-lst kw-val-lst core-arg-name ...))))] [implicit-kw-proc ;; let λ handle optional by-position arguments and arity (make-keyword-procedure (lambda/name (kw-lst kw-val-lst by-pos-formal ... . (~? rest-arg-name ())) #:name inferred-name (explicit-kws-proc kw-lst kw-val-lst by-pos-name ... (~? rest-arg-name))) (lambda/name (by-pos-formal ... . (~? rest-arg-name ())) #:name inferred-name (explicit-kws-proc '() '() by-pos-name ... (~? rest-arg-name))))]) (procedure-reduce-keyword-arity-mask implicit-kw-proc ;; optimization: compute arity mask statically (procedure-arity-mask implicit-kw-proc) '(reqired-kw ...) ;; accept all keywords #f))]) On Thu, Aug 29, 2019 at 4:24 PM Kevin Forchione <lyss...@gmail.com> wrote: > Hi guys, > I’ve been working for a little while with the idea of being able to pass > keyword arguments through a function that doesn’t define them. Additionally > I wanted to allow the “pass-through” function to define its own keywords. > Additionally didn’t want to have to pre-specify what function might be on > the receiving end of the call. But finally, if both pass-through and called > functions define the same keywords I didn’t want to have to differentiate > between them. > > - This seems to involve some combination of make-keyword-procedure and > keyword-apply. > - Since make-keyword-procedure expects a “vanilla” function (one without > keywords specified) I decided to define a macro that would wrap the > function in a let that with default bindings for each keyword defined by > the pass-through. Inside the function I would then assign any values > provided by the function call to those variables. > - Additionally I would build a parameterized list of keywords defined by > the pass-through chain. These would be used in conjunction with the keyword > list produced by procedure-keywords and the keywords/values captured by the > function call to “filter” the lists used by keyword-apply. The idea being > to eliminate any keyword/values supplied to the pass-through and defined by > the pass-through that were not defined by the called function. This would > allow keywords not defined by either to be error by the called function. > > As you can see, it’s a convoluted approach and I’m not sure how robust it > actually. I’m presenting working code (for my test cases…) but also > wondering if someone hasn’t already crated that wheel. :) > > #lang racket > > (require (for-syntax syntax/parse > racket/syntax)) > > (define current-caller-kw (make-parameter '())) > > (define (get-kw-val w v kw kv) > (define key (string->keyword (symbol->string w))) > (define kws (list->vector kw)) > (define idx (vector-member key kws)) > (cond > [(false? idx) v] > [else (define kvs (list->vector kv)) > (vector-ref kvs idx)])) > > (define-syntax (def stx) > (syntax-parse stx > [(_ (f ((w v) ...) k ... . ks) body0 body ...) > (with-syntax ([kw (format-id #'f "kw")] > [kv (format-id #'f "kv")]) > #'(define f > (let ([w v] ...) > (make-keyword-procedure > (λ (kw kv k ... . ks) > (parameterize ([current-caller-kw > (append (current-caller-kw) > (map (λ (x) (string->keyword > (symbol->string x))) > (list 'w ...)))]) > (set! w (get-kw-val 'w w kw kv)) ... > body0 body ...))))))])) > > (define (filter/kw ckw fkw kw kv) > (cond > [(empty? ckw) (values kw kv)] > [(empty? (remove* fkw ckw)) (values kw kv)] > [else > (define diff (remove* fkw ckw)) > (define vkw (list->vector kw)) > (define vkv (list->vector kv)) > (for/fold ([wacc '()] [vacc '()]) > ([v kv] > [k kw] #:unless (member k diff)) > (values (append wacc (list k)) (append vacc (list v))))])) > > (define (h #:c c . x) (list c x)) > > (def (g ((c 0)) . args) > (define-values (rkw akw) (procedure-keywords h)) > (define-values (Δkw Δkv) (filter/kw (current-caller-kw) akw kw kv)) > (list c (keyword-apply h > Δkw > Δkv > args))) > (def (f ((a 0)(b 0)) n p . ns) (list kw kv a b n p ns (keyword-apply g > kw > kv > ns))) > > > ;=> '((#:a #:c) (42 52) 42 0 2 3 (4 5) (52 (52 (4 5)))) > (f 2 3 4 5 #:a 42 #:c 52) > ;=> application: procedure does not expect an argument with given keyword > ; procedure: h > ; given keyword: #:z > ; arguments...: > (f 2 3 4 5 #:z 42 #:c 52) > > Kevin > > -- > You received this message because you are subscribed to the Google Groups > "Racket Users" group. > To unsubscribe from this group and stop receiving emails from it, send an > email to racket-users+unsubscr...@googlegroups.com. > To view this discussion on the web visit > https://groups.google.com/d/msgid/racket-users/27D5D96D-F9D9-4ECB-9AE0-92FD1EB065C8%40gmail.com > . > -- You received this message because you are subscribed to the Google Groups "Racket Users" group. To unsubscribe from this group and stop receiving emails from it, send an email to racket-users+unsubscr...@googlegroups.com. To view this discussion on the web visit https://groups.google.com/d/msgid/racket-users/CAH3z3gY-35%3Dxi3okpHrNpKKzsnf1-WMuGsg0Wzn3D5BPgso-Bw%40mail.gmail.com.
