commit fa82c91cd7c113063fe2fadfb4d8592363cd1aed Author: AlexKnauth <alexander@knauth.org> Date: Tue, 11 Nov 2014 22:02:41 -0500 Initial commit Diffstat:
| A | .gitignore | | | 2 | ++ |
| A | info.rkt | | | 8 | ++++++++ |
| A | kw-utils/arity+keywords.rkt | | | 448 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | kw-utils/docs/arity+keywords.scrbl | | | 133 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | kw-utils/docs/keyword-apply-sort.scrbl | | | 26 | ++++++++++++++++++++++++++ |
| A | kw-utils/docs/keyword-lambda.scrbl | | | 26 | ++++++++++++++++++++++++++ |
| A | kw-utils/docs/kw-utils.scrbl | | | 14 | ++++++++++++++ |
| A | kw-utils/info.rkt | | | 4 | ++++ |
| A | kw-utils/keyword-apply-sort.rkt | | | 30 | ++++++++++++++++++++++++++++++ |
| A | kw-utils/keyword-lambda.rkt | | | 37 | +++++++++++++++++++++++++++++++++++++ |
10 files changed, 728 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore @@ -0,0 +1,2 @@ +*~ +compiled/ diff --git a/info.rkt b/info.rkt @@ -0,0 +1,8 @@ +#lang info + +(define collection 'multi) + +(define deps '("base")) + +(define build-deps '("rackunit-lib" "scribble-lib" "racket-doc")) + diff --git a/kw-utils/arity+keywords.rkt b/kw-utils/arity+keywords.rkt @@ -0,0 +1,448 @@ +#lang racket/base + +(provide (struct-out arity+keywords) + empty-arity+keywords + any-arity+keywords + procedure-arity+keywords + procedure-reduce-arity+keywords + procedure-reduce-keyword-arity/sort + arity+keywords-matches? + procedure-arity+keywords-matches? + procedure-arity+keywords-matches?/c + arity+keywords-combine/or + arity+keywords-combine/and + arity+keywords-combine + arity+keywords-subtract + ) + +(require racket/function + racket/bool + racket/contract/base + racket/list + racket/match + (for-syntax racket/base + )) + +(module+ test + (require rackunit racket/local racket/math)) + +(define (arity+keywords-guard arity required-kws allowed-kws _) + (unless (procedure-arity? arity) + (error 'arity+keywords "expected procedure-arity? for first argument, given ~v" arity)) + (unless ((listof keyword?) required-kws) + (error 'arity+keywords + "expcetd (listof keyword?) for second argument, given ~v" + required-kws)) + (unless ((or/c (listof keyword?) #t #f) allowed-kws) + (error 'arity+keywords + "expcetd (or/c (listof keyword?) #f) for third argument, given ~v" + required-kws)) + (define new-arity (normalize-arity arity)) + (define new-required-kws + (cond [(empty? new-arity) '()] + [else (sort required-kws keyword<?)])) + (define new-allowed-kws + (cond [(empty? new-arity) '()] + [(list? allowed-kws) + (sort (remove-duplicates (append new-required-kws allowed-kws)) + keyword<?)] + [else #f])) + (values new-arity new-required-kws new-allowed-kws)) + +;; arity+keywords : Procedure-Arity (Listof Keyword) (or/c (Listof Keyword) #f) -> Arity+Keywords +(struct arity+keywords (arity required-kws allowed-kws) #:transparent + #:guard arity+keywords-guard) + +(define empty-arity+keywords (arity+keywords '() '() '())) +(define any-arity+keywords (arity+keywords (arity-at-least 0) '() #f)) + +;; procedure-arity+keywords : Procedure -> Arity+Keywords +(define (procedure-arity+keywords proc) + (define arity (procedure-arity proc)) + (define-values (req-kws allowed-kws) + (procedure-keywords proc)) + (arity+keywords arity req-kws allowed-kws)) + +;; proceudre-reduce-arity+keywords : Procedure Arity+Keywords -> Procedure +(define (procedure-reduce-arity+keywords proc a) + (match-define (arity+keywords arity required-kws allowed-kws) a) + (procedure-reduce-keyword-arity + proc + arity + required-kws + allowed-kws)) + +;; like procedure-reduce-keyword-arity, but without the constraint that the kws must be sorted +(define (procedure-reduce-keyword-arity/sort proc arity required-kws allowed-kws) + (procedure-reduce-arity+keywords + proc + (arity+keywords arity required-kws allowed-kws))) + +;; arity+keywords-matches? : Arity+Keywords Natural (Listof Keyword) -> Boolean +;; see also arity+keywords-includes? +(define (arity+keywords-matches? arity+kws n kws) + (match-define (arity+keywords arity required-kws allowed-kws) arity+kws) + (and (arity-includes? arity n) + (or (false? allowed-kws) + (for/and ([kw (in-list kws)]) + (member kw allowed-kws))) + (for/and ([required-kw (in-list required-kws)]) + (member required-kw kws)) + #t)) + +;; procedure-arity+keywords-matches? : Procedure Natural (Listof Keyword) -> Boolean +(define (procedure-arity+keywords-matches? proc n kws) + (arity+keywords-matches? (procedure-arity+keywords proc) n kws)) + +;; procedure-arity+keywords-matches?/c : Natural (Listof Keyword) -> (Procedure -> Boolean) +(define (procedure-arity+keywords-matches?/c n kws) + (flat-named-contract + `(procedure-arity+keywords-matches?/c ,n (quote ,kws)) + (lambda (proc) + (procedure-arity+keywords-matches? proc n kws)))) + +;; arity+keywords-includes? : Arity+Keywords Arity+Keywords -> Boolean +;; see also arity+keywords-matches? +(define (arity+keywords-includes? a1 a2) + (match-define (arity+keywords a1.arity a1.req-kws a1.allowed-kws) a1) + (match-define (arity+keywords a2.arity a2.req-kws a2.allowed-kws) a2) + (and (arity-includes? a1.arity a2.arity) + (for/and ([a1-kw (in-list a1.req-kws)]) + (member a1-kw a2.req-kws)) + (cond [(false? a1.allowed-kws) #t] + [(false? a2.allowed-kws) #f] + [else (for/and ([a2-kw (in-list a2.allowed-kws)]) + (member a2-kw a1.allowed-kws))]) + #t)) + +;; arity+keywords-combine/or : Arity+Keywords ... -> Arity+Keywords +(define arity+keywords-combine/or + (case-lambda + [() empty-arity+keywords] + [(a) a] + [(a1 a2) (match-define (arity+keywords a1.arity a1.required-kws a1.allowed-kws) a1) + (match-define (arity+keywords a2.arity a2.required-kws a2.allowed-kws) a2) + (cond + [(andmap empty? (list a1.arity a2.arity)) empty-arity+keywords] + [(empty? a1.arity) a2] + [(empty? a2.arity) a1] + [else + (define arity + (normalize-arity (flatten (list a1.arity a2.arity)))) + (define required-kws + (for*/list ([a1-kw (in-list a1.required-kws)] + [a2-kw (in-list a2.required-kws)] + #:when (equal? a1-kw a2-kw)) + a1-kw)) + (define allowed-kws + (and a1.allowed-kws a2.allowed-kws + (remove-duplicates + (append a1.allowed-kws + a2.allowed-kws)))) + (arity+keywords arity required-kws allowed-kws)])] + [(a1 . rest-args) (arity+keywords-combine/or a1 (apply arity+keywords-combine/or rest-args))] + )) + +(define (arity+keywords-combine-warning) + (with-handlers ([exn:fail? (λ (e) ((error-display-handler) (exn-message e) e))]) + (error 'arity+keywords-combine + (string-append "please use arity+keywords-combine/or instead" "\n" + " (to avoid confusion with arity+keywords-combine/and)")))) +(define-syntax arity+keywords-combine + (lambda (stx) + (with-handlers ([exn:fail:syntax? (λ (e) ((error-display-handler) (exn-message e) e))]) + (raise-syntax-error #f + (string-append "please use arity+keywords-combine/or instead" "\n" + " (to avoid confusion with arity+keywords-combine/and)") + stx)) + (syntax-case stx () + [(arity+keywords-combine . stuff) + (quasisyntax/loc stx + (begin + #,(syntax/loc stx (arity+keywords-combine-warning)) + #,(syntax/loc stx (arity+keywords-combine/or . stuff))))] + [arity+keywords-combine + (quasisyntax/loc stx + (begin + #,(syntax/loc stx (arity+keywords-combine-warning)) + #,(quasisyntax/loc stx + (λ args #,(syntax/loc stx (arity+keywords-combine-warning)) + (apply arity+keywords-combine/or args)))))]))) + +;; arity+keywords-combine/and : Arity+Keywords ... -> Arity+Keywords +(define arity+keywords-combine/and + (case-lambda + [() any-arity+keywords] + [(a) a] + [(a1 a2) (match-define (arity+keywords a1.arity a1.required-kws a1.allowed-kws) a1) + (match-define (arity+keywords a2.arity a2.required-kws a2.allowed-kws) a2) + (define arity + (arity-combine/and a1.arity a2.arity)) + (define required-kws + (remove-duplicates + (append a1.required-kws + a2.required-kws))) + (define allowed-kws + (cond [(not (list? a1.allowed-kws)) a2.allowed-kws] + [(not (list? a2.allowed-kws)) a1.allowed-kws] + [else + (for*/list ([a1-kw (in-list a1.allowed-kws)] + [a2-kw (in-list a2.allowed-kws)] + #:when (equal? a1-kw a2-kw)) + a1-kw)])) + (cond [(for/and ([req-kw (in-list required-kws)]) + (member req-kw allowed-kws)) + (arity+keywords arity required-kws allowed-kws)] + [else empty-arity+keywords])] + [(a1 . rest-args) (arity+keywords-combine/and a1 (apply arity+keywords-combine/and rest-args))] + )) + +;; arity-combine/and : Procedure-Arity Procedure-Arity -> Procedure-Arity +(define (arity-combine/and a1 a2) + (let ([a1 (normalize-arity a1)] + [a2 (normalize-arity a2)]) + (cond [(arity-includes? a1 a2) a2] + [(arity-includes? a2 a1) a1] + [(number? a1) + (cond [(arity-includes? a2 a1) a1] + [else '()])] + [(number? a2) + (cond [(arity-includes? a1 a2) a2] + [else '()])] + [(arity-at-least? a1) + (cond [(arity-includes? a2 a1) a1] + [(number? a2) '()] + [(arity-at-least? a2) + (arity-at-least (max (arity-at-least-value a1) + (arity-at-least-value a2)))] + [(list? a2) + (normalize-arity + (flatten + (for/list ([n (in-list a2)]) + (arity-combine/and a1 n))))] + [else (error 'arity-combine/and "this should never happen")])] + [(arity-at-least? a2) + (cond [(arity-includes? a1 a2) a2] + [(number? a1) '()] + [(arity-at-least? a1) + (arity-at-least (max (arity-at-least-value a1) + (arity-at-least-value a2)))] + [(list? a1) + (normalize-arity + (flatten + (for/list ([n (in-list a1)]) + (arity-combine/and a2 n))))] + [else (error 'arity-combine/and "this should never happen")])] + [(list? a1) + (normalize-arity + (flatten + (for/list ([n (in-list a1)]) + (arity-combine/and a2 n))))] + [(list? a2) + (normalize-arity + (flatten + (for/list ([n (in-list a2)]) + (arity-combine/and a1 n))))] + [else (error 'arity-combine/and "this should never happen")]))) + + +;; arity+keywords-subtract : Arity+Keywords Natural (Listof Keyword) -> Arity+Keywords +(define (arity+keywords-subtract a n kws) + (match-define (arity+keywords a.arity a.req-kws a.allowed-kws) a) + (define arity (arity-subtract a.arity n)) + (cond [(empty? arity) empty-arity+keywords] + [(not (list? a.allowed-kws)) + (define req-kws + (remove* kws a.req-kws)) + (define allowed-kws #f) + (arity+keywords arity req-kws allowed-kws)] + [(not (for/and ([kw (in-list kws)]) + (member kw a.allowed-kws))) + empty-arity+keywords] + [else + (define req-kws + (remove* kws a.req-kws)) + (define allowed-kws + (remove* kws a.allowed-kws)) + (arity+keywords arity req-kws allowed-kws)])) + +;; arity-subtract : Procedure-Arity Natural -> Procedure-Arity +(define (arity-subtract arity n) + (arity-map + (λ (a) + (arity-subtract/simple a n)) + arity)) + +;; arity-subtract/simple : [(U Natural (arity-at-least Natural)) Natural -> Procedure-Arity] +(define (arity-subtract/simple a n) + (cond [(number? a) + (define new-a (- a n)) + (cond [(negative? new-a) '()] + [else new-a])] + [(arity-at-least? a) + (define a.n (arity-at-least-value a)) + (define new-a.n (- a.n n)) + (cond [(negative? new-a.n) (arity-at-least 0)] + [else (arity-at-least new-a.n)])] + [else (error 'arity-subtract/simple "this should never happen")])) + +;;(define-type Nat/Aal->Ar [(U Natural (arity-at-least Natural)) -> Procedure-Arity]) + +;; arity-map : [Nat/Aal->Ar Procedure-Arity -> Procedure-Arity] +(define (arity-map proc arity) + (let ([arity (normalize-arity arity)]) + (cond [(number? arity) (normalize-arity (proc arity))] + [(arity-at-least? arity) (normalize-arity (proc arity))] + [(list? arity) (normalize-arity (flatten (map proc arity)))] + [else (error 'arity-map "this should never happen, given ~v" arity)]))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module+ test + (test-case "the arity+keywords constructor and guard" + (check-equal? (arity+keywords (list 1 (arity-at-least 3) 2) '() #t) + (arity+keywords (arity-at-least 1) '() #f)) + (check-equal? (arity+keywords '(1) '(#:a #:b) '(#:c)) + (arity+keywords 1 '(#:a #:b) '(#:a #:b #:c)))) + + (test-case "procedure-arity+keywords and procedure-reduce-arity+keywords" + (define proc (make-keyword-procedure void)) + (check-equal? (procedure-arity+keywords proc) + (arity+keywords (arity-at-least 0) '() #f)) + (check-equal? (procedure-arity+keywords (procedure-reduce-arity proc 5)) + (arity+keywords 5 '() '())) + (define proc-with-arity + (procedure-reduce-arity+keywords + proc + (arity+keywords 3 '(#:kw #:other-kw) '(#:kw #:other-kw #:optional-kw)))) + (check-equal? (procedure-arity+keywords proc-with-arity) + (arity+keywords 3 '(#:kw #:other-kw) '(#:kw #:other-kw #:optional-kw))) + (check-equal? (procedure-arity proc-with-arity) 3) + (check-equal? (call-with-values (λ () (procedure-keywords proc-with-arity)) list) + (list '(#:kw #:other-kw) '(#:kw #:optional-kw #:other-kw)))) + + (test-case "arity+keywords-matches?" + (check-true (arity+keywords-matches? (arity+keywords 0 '() '()) 0 '())) + (check-false (arity+keywords-matches? (arity+keywords 0 '() '()) 1 '())) + (check-false (arity+keywords-matches? (arity+keywords '() '() #f) 0 '())) + (check-true (arity+keywords-matches? (arity+keywords (list 2 (arity-at-least 5)) + '() '()) + 2 '())) + (check-false (arity+keywords-matches? (arity+keywords (list 2 (arity-at-least 5)) + '() '()) + 3 '())) + (check-true (arity+keywords-matches? (arity+keywords (list 2 (arity-at-least 5)) + '() '()) + 5 '())) + (check-true (arity+keywords-matches? (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c)) + 0 '(#:a #:b))) + (check-true (arity+keywords-matches? (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c)) + 0 '(#:a #:b #:c))) + (check-false (arity+keywords-matches? (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c)) + 0 '(#:a #:c))) + (check-true (arity+keywords-matches? (arity+keywords 0 '() #f) + 0 '(#:whatever)))) + + (test-case "arity+keywords-includes?" + (check-true (arity+keywords-includes? (arity+keywords 1 '() '()) + (arity+keywords 1 '() '()))) + (check-true (arity+keywords-includes? (arity+keywords '(1 2) '() '()) + (arity+keywords 1 '() '()))) + (check-false (arity+keywords-includes? (arity+keywords 1 '() '()) + (arity+keywords '(1 2) '() '()))) + (check-true (arity+keywords-includes? (arity+keywords 0 '() #f) + (arity+keywords 0 '() '(#:a)))) + (check-true (arity+keywords-includes? (arity+keywords 0 '() #f) + (arity+keywords 0 '(#:a) '(#:a)))) + (check-false (arity+keywords-includes? (arity+keywords 0 '(#:a) #f) + (arity+keywords 0 '() '(#:a)))) + (check-true (arity+keywords-includes? (arity+keywords 0 '() '(#:a #:b)) + (arity+keywords 0 '(#:a) '(#:a)))) + (check-false (arity+keywords-includes? (arity+keywords 0 '() '()) + (arity+keywords 0 '() #f)))) + + (test-case "arity+keywords-combine/or" + (check-equal? (arity+keywords-combine/or) (arity+keywords '() '() '())) + (check-equal? (arity+keywords-combine/or (arity+keywords '(4 9 16) '(#:a #:b) '(#:a #:b #:c))) + (arity+keywords '(4 9 16) '(#:a #:b) '(#:a #:b #:c))) + (check-equal? (arity+keywords-combine/or (arity+keywords 1 '(#:a) '(#:a #:b #:c)) + (arity+keywords 2 '(#:a #:b) '(#:a #:b #:d))) + (arity+keywords '(1 2) '(#:a) '(#:a #:b #:c #:d)))) + + (test-case "arity+keywords-combine/and" + (check-equal? (arity+keywords-combine/and) (arity+keywords (arity-at-least 0) '() #f)) + (check-equal? (arity+keywords-combine/and (arity+keywords '(4 9 16) '(#:a #:b) '(#:a #:b #:c))) + (arity+keywords '(4 9 16) '(#:a #:b) '(#:a #:b #:c))) + (check-equal? (arity+keywords-combine/and (arity+keywords '(1 2) '(#:a) '(#:a #:b #:c #:d)) + (arity+keywords '(2 3) '(#:b) '(#:a #:b #:c #:e))) + (arity+keywords 2 '(#:a #:b) '(#:a #:b #:c))) + (check-match (arity+keywords-combine/and (arity+keywords 0 '(#:a) #f) + (arity+keywords 0 '() '())) + (arity+keywords '() _ _))) + + (test-case "arity+keywords-subtract" + (check-equal? (arity+keywords-subtract (arity+keywords 0 '() '()) 0 '()) + (arity+keywords 0 '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords 1 '() '()) 0 '()) + (arity+keywords 1 '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords 1 '() '()) 1 '()) + (arity+keywords 0 '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords '(0 1) '() '()) 0 '()) + (arity+keywords '(0 1) '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords '(0 1) '() '()) 1 '()) + (arity+keywords 0 '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords '(3 7 10) '() '()) 5 '()) + (arity+keywords '(2 5) '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords (arity-at-least 0) '() '()) 5 '()) + (arity+keywords (arity-at-least 0) '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords (arity-at-least 49) '() '()) 57 '()) + (arity+keywords (arity-at-least 0) '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords (arity-at-least 57) '() '()) 49 '()) + (arity+keywords (arity-at-least 8) '() '())) + (check-equal? (arity+keywords-subtract (arity+keywords (list 3 7 10 (arity-at-least 47)) '() '()) + 5 '()) + (arity+keywords (list 2 5 (arity-at-least 42)) '() '())) + + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) #f) 0 '()) + (arity+keywords 0 '(#:a #:b) #f)) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) #f) 0 '(#:a)) + (arity+keywords 0 '(#:b) #f)) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) #f) 0 '(#:b)) + (arity+keywords 0 '(#:a) #f)) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) #f) 0 '(#:a #:b)) + (arity+keywords 0 '() #f)) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) 0 '()) + (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) 0 '(#:a)) + (arity+keywords 0 '(#:b) '(#:b #:c #:d))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) 0 '(#:b)) + (arity+keywords 0 '(#:a) '(#:a #:c #:d))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) 0 '(#:c)) + (arity+keywords 0 '(#:a #:b) '(#:a #:b #:d))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) 0 '(#:d)) + (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) + 0 '(#:a #:b)) + (arity+keywords 0 '() '(#:c #:d))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) + 0 '(#:a #:c)) + (arity+keywords 0 '(#:b) '(#:b #:d))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) + 0 '(#:a #:d)) + (arity+keywords 0 '(#:b) '(#:b #:c))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) + 0 '(#:b #:c)) + (arity+keywords 0 '(#:a) '(#:a #:d))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) + 0 '(#:b #:d)) + (arity+keywords 0 '(#:a) '(#:a #:c))) + (check-equal? (arity+keywords-subtract (arity+keywords 0 '(#:a #:b) '(#:a #:b #:c #:d)) + 0 '(#:c #:d)) + (arity+keywords 0 '(#:a #:b) '(#:a #:b))) + ) + + ) + + diff --git a/kw-utils/docs/arity+keywords.scrbl b/kw-utils/docs/arity+keywords.scrbl @@ -0,0 +1,133 @@ +#lang scribble/manual +@(require kw-utils/arity+keywords + racket/base + scribble/eval + (for-label kw-utils/arity+keywords + racket/base + racket/contract/base + racket/function + )) + +@title[#:tag "arity+keywords.scrbl"]{arity+keywords} + +@defmodule[kw-utils/arity+keywords] + +@defstruct*[arity+keywords ([arity procedure-arity?] + [required-kws (listof keyword?)] + [allowed-kws (or/c (listof keyword?) #f)]) + #:transparent]{ +represents a procedure's arity including the keywords required and keywords allowed. + +The @racket[arity] field represents the arity produced by @racket[procedure-arity]. + +The next 2 fields (@racket[required-kws] and @racket[allowed-kws]) represent the 2 values produced by +@racket[procedure-keywords]. + +A @racket[#f] value for @racket[allowed-kws] means that it accepts all keywords. + +The guard procedure also sorts the keyword lists for you. +} + +@defproc[(procedure-arity+keywords [proc procedure?]) arity+keywords?]{ +returns an @racket[arity+keywords] instance representing the arity and keyword-arity of @racket[proc]. + +It is defined like this: +@(racketblock + (define (procedure-arity+keywords proc) + (define arity (procedure-arity proc)) + (define-values (req-kws allowed-kws) + (procedure-keywords proc)) + (arity+keywords arity req-kws allowed-kws))) + +@examples[ + (require kw-utils/arity+keywords) + (define proc (make-keyword-procedure void)) + (procedure-arity+keywords proc) + (procedure-arity+keywords (procedure-reduce-arity proc 5)) + (procedure-arity+keywords + (procedure-reduce-keyword-arity/sort proc 3 '(#:kw #:other-kw) '(#:kw #:other-kw #:optional-kw))) +]} + +@defproc[(procedure-reduce-arity+keywords [proc procedure?] [arity+kws arity+keywords?]) procedure?]{ +like @racket[procedure-reduce-arity], except that it accepts an @racket[arity+keywords] and handles +the keyword-arity as well. + +It is defined like this: +@(racketblock + (define (procedure-reduce-arity+keywords proc a) + (procedure-reduce-keyword-arity + proc + (arity+keywords-arity a) + (arity+keywords-required-kws a) + (arity+keywords-allowed-kws a)))) + +@examples[ + (require kw-utils/arity+keywords) + (define proc (make-keyword-procedure void)) + (procedure-arity proc) + (procedure-keywords proc) + (define proc-with-arity + (procedure-reduce-arity+keywords + proc + (arity+keywords 5 '(#:kw #:other-kw) '(#:kw #:other-kw #:optional-kw)))) + (procedure-arity proc-with-arity) + (procedure-keywords proc-with-arity) +]} + +@defproc[(procedure-reduce-keyword-arity/sort [proc procedure?] + [arity procedure-arity?] + [required-kws (listof keyword?)] + [allowed-kws (or/c (listof keyword?) #f)]) + procedure?]{ +like @racket[procedure-reduce-keyword-arity], but without the constraint that the keywords in +@racket[required-kws] or @racket[allowed-kws] must be sorted. + +It is equivalent to +@racket[(procedure-reduce-arity+keywords proc (arity+keywords arity required-kws allowed-kws))]. +} + +@defproc[(arity+keywords-matches? [arity+kws arity+keywords?] + [n natural-number/c] + [kws (listof keyword?)]) + boolean?]{ +determines whether the given @racket[arity+kws] accepts the @racket[n] by-position arguments and the +keywords in @racket[kws]. +} + +@defproc[(procedure-arity+keywords-matches? [proc procedure?] + [n natural-number/c] + [kws (listof keyword?)]) + boolean?]{ +equivalent to @racket[(arity+keywords-matches? (procedure-arity+keywords proc) n kws)]. +} + +@defproc[(procedure-arity+keywords-matches?/c [n natural-number/c] + [kws (listof keyword?)]) + flat-contract?]{ +produces a flat contract (also a predicate) that accepts procedures that accept @racket[n] by-position +arguments and accepts the keywords in @racket[kws]. +} + +@defproc[(arity+keywords-includes? [a1 arity+keywords?] [a2 arity+keywords?]) boolean?]{ +like @racket[arity-includes?], but for @racket[arity+keywords] instances. But most of the time when +when you would use @racket[arity-includes?], you really want @racket[arity+keywords-matches?]. +} + +@defproc[(arity+keywords-combine/or [arity+kws arity+keywords?] ...) arity+keywords?]{ +combines the @racket[arity+kws]es into one @racket[arity+keywords] instance in an or-like way. + +@examples[ + (require kw-utils/arity+keywords) + (arity+keywords-combine/or (arity+keywords 1 '(#:a) '(#:a #:b #:c)) + (arity+keywords 2 '(#:a #:b) '(#:a #:b #:d))) +]} + +@defproc[(arity+keywords-combine/and [arity+kws arity+keywords?] ...) arity+keywords?]{ +combines the @racket[arity+kws]es into one @racket[arity+keywords] instance in an and-like way. + +@examples[ + (require kw-utils/arity+keywords) + (arity+keywords-combine/and (arity+keywords '(1 2) '(#:a) '(#:a #:b #:c #:d)) + (arity+keywords '(2 3) '(#:b) '(#:a #:b #:c #:e))) +]} + diff --git a/kw-utils/docs/keyword-apply-sort.scrbl b/kw-utils/docs/keyword-apply-sort.scrbl @@ -0,0 +1,26 @@ +#lang scribble/manual +@(require kw-utils/keyword-apply-sort + racket/base + scribble/eval + (for-label kw-utils/keyword-apply-sort + racket/base + racket/contract/base + racket/math + )) + +@title[#:tag "keyword-apply-sort.scrbl"]{keyword-apply/sort} + +@defmodule[kw-utils/keyword-apply-sort] + +@defproc[(keyword-apply/sort [f procedure?] [kws (listof keyword?)] [kw-args list?] + [v any/c] ... [lst list?] [#:<kw> kw-arg any/c] ...) any]{ +like @racket[keyword-apply], but without the constraint that the keywords in @racket[kws] must be +sorted. + +@examples[ + (require kw-utils/keyword-apply-sort racket/math) + (define (kinetic-energy #:mass m #:velocity v) + (* 1/2 m (sqr v))) + (keyword-apply/sort kinetic-energy '(#:mass #:velocity) '(2 1) '()) + (keyword-apply/sort kinetic-energy '(#:velocity #:mass) '(1 2) '()) +]} diff --git a/kw-utils/docs/keyword-lambda.scrbl b/kw-utils/docs/keyword-lambda.scrbl @@ -0,0 +1,26 @@ +#lang scribble/manual +@(require kw-utils/keyword-lambda + racket/base + scribble/eval + (for-label kw-utils/keyword-lambda + racket/base)) + +@title[#:tag "keyword-lambda.scrbl"]{keyword-lambda} + +@defmodule[kw-utils/keyword-lambda] + +@defform[(keyword-lambda (kws kw-args . rest-args) body ...)]{ +roughly equivalent to +@(racketblock + (make-keyword-procedure + (lambda (kws kw-args . rest-args) body ...)) + ) + +@examples[ + (require kw-utils/keyword-lambda) + (define proc + (keyword-lambda (kws kw-args . rest-args) + (list kws kw-args rest-args))) + (proc #:a 'a #:b 'b 0 1 2) +]} + diff --git a/kw-utils/docs/kw-utils.scrbl b/kw-utils/docs/kw-utils.scrbl @@ -0,0 +1,14 @@ +#lang scribble/manual + +@title[#:style '(toc) #:tag "kw-utils.scrbl"]{Keyword Utils} + +source code: @url["https://github.com/AlexKnauth/kw-utils"] + +@local-table-of-contents[] + +@include-section[(lib "kw-utils/docs/keyword-lambda.scrbl")] + +@include-section[(lib "kw-utils/docs/keyword-apply-sort.scrbl")] + +@include-section[(lib "kw-utils/docs/arity+keywords.scrbl")] + diff --git a/kw-utils/info.rkt b/kw-utils/info.rkt @@ -0,0 +1,4 @@ +#lang info + +(define scribblings '(["docs/kw-utils.scrbl" (multi-page)])) + diff --git a/kw-utils/keyword-apply-sort.rkt b/kw-utils/keyword-apply-sort.rkt @@ -0,0 +1,30 @@ +#lang racket/base + +(provide keyword-apply/sort) + +(require "keyword-lambda.rkt") + +(module+ test + (require rackunit racket/local racket/math)) + +;; like keyword-apply, but without the constraint that the kws must be sorted +(define keyword-apply/sort + (keyword-lambda (kws kw-args f other-kws other-kw-args . rest-args) + (let* ([kw-lop (for/list ([kw (in-list (append kws other-kws))] + [kw-arg (in-list (append kw-args other-kw-args))]) + (cons kw kw-arg))] + [sorted-kw-lop (sort kw-lop keyword<? #:key car)] + [sorted-kws (map car sorted-kw-lop)] + [sorted-kw-args (map cdr sorted-kw-lop)]) + (keyword-apply f sorted-kws sorted-kw-args (apply list* rest-args))))) + +(module+ test + (local [] + (define (kinetic-energy #:mass m #:velocity v) + (* 1/2 m (sqr v))) + (check-equal? (keyword-apply/sort kinetic-energy '(#:mass #:velocity) '(2 1) '()) + 1) + (check-equal? (keyword-apply/sort kinetic-energy '(#:velocity #:mass) '(1 2) '()) + 1) + )) + diff --git a/kw-utils/keyword-lambda.rkt b/kw-utils/keyword-lambda.rkt @@ -0,0 +1,37 @@ +#lang racket/base + +(provide keyword-lambda) + +(require (for-syntax racket/base syntax/parse syntax/name)) + +(module+ test + (require rackunit racket/local)) + +;; (keyword-lambda (kws kw-args . rest-args) body ...+) +(define-syntax keyword-lambda + (lambda (stx) + (syntax-parse stx + [(keyword-lambda (kws:id kw-args:id . rest-args) body:expr ...+) + (define name (syntax-local-infer-name stx)) + (cond [(or (symbol? name) (identifier? name)) + (with-syntax ([name name]) + #'(make-keyword-procedure + (lambda (kws kw-args . rest-args) body ...) + (let ([name (lambda rest-args + (let ([kws '()] [kw-args '()]) + body ...))]) + name)))] + [else #'(make-keyword-procedure + (lambda (kws kw-args . rest-args) body ...) + (lambda rest-args + (let ([kws '()] [kw-args '()]) + body ...)))])]))) + +(module+ test + (local [(define proc + (keyword-lambda (kws kw-args . rest-args) + (list kws kw-args rest-args)))] + (check-equal? (proc #:a 'a #:b 'b 0 1 2) + (list '(#:a #:b) '(a b) '(0 1 2))) + (check-equal? (object-name proc) 'proc) + ))