diff --git a/pkgs/racket-doc/scribblings/reference/procedures.scrbl b/pkgs/racket-doc/scribblings/reference/procedures.scrbl index 4bd543a5fc..87f5d93da1 100644 --- a/pkgs/racket-doc/scribblings/reference/procedures.scrbl +++ b/pkgs/racket-doc/scribblings/reference/procedures.scrbl @@ -562,6 +562,38 @@ returns the @racket[not] of @racket[proc]'s result. (map (negate =) '(1 2 3) '(1 1 1)) ]} +@defproc[((conjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{ + +Combines calls to each function with @racket[and]. Equivalent to +@racket[(and (f x ...) ...)] + +@defexamples[ +#:eval fun-eval +(define f (conjoin exact? integer?)) +(f 1) +(f 1.0) +(f 1/2) +(f 0.5) +] + +} + +@defproc[((disjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{ + +Combines calls to each function with @racket[or]. Equivalent to +@racket[(or (f x ...) ...)] + +@defexamples[ +#:eval fun-eval +(define f (disjoin exact? integer?)) +(f 1) +(f 1.0) +(f 1/2) +(f 0.5) +] + +} + @defproc*[([(curry [proc procedure?]) procedure?] [(curry [proc procedure?] [v any/c] ...+) any/c])]{ diff --git a/pkgs/racket-test/tests/racket/bool.rkt b/pkgs/racket-test/tests/racket/bool.rkt index d365729d22..5f2656be40 100644 --- a/pkgs/racket-test/tests/racket/bool.rkt +++ b/pkgs/racket-test/tests/racket/bool.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require racket/bool rackunit) +(require racket/bool racket/function rackunit) (check-true true) (check-false false) @@ -41,3 +41,13 @@ (check-equal? (xor 11 #f) 11) (check-equal? (xor #f 22) 22) (check-equal? (xor #f #f) #f) + +(check-true ((conjoin) 'x #:y 'z)) ; no function +(check-true ((conjoin integer? exact?) 1)) +(check-false ((conjoin integer? exact?) 1.0)) +(check-false ((conjoin integer? exact?) 0.5)) + +(check-false ((disjoin) 'x #:y 'z)) ; no function +(check-true ((disjoin integer? exact?) 1)) +(check-true ((disjoin integer? exact?) 1/2)) +(check-false ((disjoin integer? exact?) 0.5)) diff --git a/racket/collects/racket/function.rkt b/racket/collects/racket/function.rkt index a5deb1a183..6187c80773 100644 --- a/racket/collects/racket/function.rkt +++ b/racket/collects/racket/function.rkt @@ -1,9 +1,11 @@ #lang racket/base -(require (for-syntax racket/base syntax/name) racket/private/norm-arity) +(require (for-syntax racket/base racket/list syntax/name) + racket/match racket/private/arity) (provide identity const thunk thunk* negate curry curryr - normalize-arity normalized-arity? arity=? arity-includes?) + (all-from-out racket/private/arity) + conjoin disjoin) (define (identity x) x) @@ -82,104 +84,126 @@ (define curry (make-curry #f)) (define curryr (make-curry #t)) -(define (normalized-arity? a) - (or (null? a) - (arity? a) - (and (list? a) - ((length a) . >= . 2) - (andmap arity? a) - (if (ormap arity-at-least? a) - (non-empty-non-singleton-sorted-list-ending-with-arity? a) - (non-singleton-non-empty-sorted-list? a))))) -(define (arity? a) - (or (exact-nonnegative-integer? a) - (and (arity-at-least? a) - (exact-nonnegative-integer? (arity-at-least-value a))))) +;; Originally from `unstable/function`. +;; Originally written by Carl Eastlund -;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean -;; know that 'a' is a list of at least 2 elements -(define (non-empty-non-singleton-sorted-list-ending-with-arity? a) - (let loop ([bound (car a)] - [lst (cdr a)]) - (cond - [(null? (cdr lst)) - (and (arity-at-least? (car lst)) - (> (arity-at-least-value (car lst)) (+ 1 bound)))] - [else - (and (exact-nonnegative-integer? (car lst)) - ((car lst) . > . bound) - (loop (car lst) - (cdr lst)))]))) +;; ryanc: adjusted limit of inner cases from 8 to 2 +;; All uses so far seem to be predicates, so more cases seem +;; unnecessary. Also, all uses so far are first-order, so +;; outer case-lambda* might be better replaced with macro. -(define (non-empty-sorted-list? a) - (and (pair? a) - (sorted-list? a))) +(define conjoin + (case-lambda* + [(f ... 8) + (make-intermediate-procedure + 'conjoined + [(x (... ...) 2) (and (f x (... ...)) ...)] + [xs (and (apply f xs) ...)] + #:keyword + [(keys vals . args) + (and (keyword-apply f keys vals args) ...)])] + [fs + (make-intermediate-procedure + 'conjoined + [(x ... 2) (andmap (lambda (f) (f x ...)) fs)] + [xs (andmap (lambda (f) (apply f xs)) fs)] + #:keyword + [(keys vals . args) + (andmap (lambda (f) (keyword-apply f keys vals args)) fs)])])) -(define (non-singleton-non-empty-sorted-list? a) - (and (pair? a) - (pair? (cdr a)) - (sorted-list? a))) +(define disjoin + (case-lambda* + [(f ... 8) + (make-intermediate-procedure + 'disjoined + [(x (... ...) 2) (or (f x (... ...)) ...)] + [xs (or (apply f xs) ...)] + #:keyword + [(keys vals . args) + (or (keyword-apply f keys vals args) ...)])] + [fs + (make-intermediate-procedure + 'disjoined + [(x ... 2) (ormap (lambda (f) (f x ...)) fs)] + [xs (ormap (lambda (f) (apply f xs)) fs)] + #:keyword + [(keys vals . args) + (ormap (lambda (f) (keyword-apply f keys vals args)) fs)])])) -(define (sorted-list? a) - (or (null? a) - (sorted/bounded-list? (cdr a) (car a)))) +(define-syntax (make-intermediate-procedure stx) + (syntax-case stx [quote] + [(_ (quote name) positional-clause ... #:keyword keyword-clause) + (syntax/loc stx + (make-keyword-procedure + (let* ([name (case-lambda keyword-clause)]) name) + (let* ([name (case-lambda* positional-clause ...)]) name)))])) -(define (sorted/bounded-list? a bound) - (or (null? a) - (and (number? (car a)) - (< bound (car a)) - (sorted/bounded-list? (cdr a) (car a))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Automatic case-lambda repetition +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (arity-supports-number? arity n) +(define-for-syntax (split-syntax-at orig stx id) + (let loop ([found #f] + [seen null] + [stx stx]) + (syntax-case stx [] + [(head . tail) + (and (identifier? #'head) + (free-identifier=? #'head id)) + (if found + (raise-syntax-error + #f + (format "duplicate occurrence of ~a" (syntax-e id)) + orig + #'head) + (loop (list (reverse seen) #'head #'tail) + (cons #'head seen) + #'tail))] + [(head . tail) (loop found (cons #'head seen) #'tail)] + [_ found]))) + +(define-for-syntax (expand-ellipsis-clause stx pattern expr) (cond - [(exact-nonnegative-integer? arity) (= arity n)] - [(arity-at-least? arity) (<= (arity-at-least-value arity) n)] - [(list? arity) - (for/or {[elem (in-list arity)]} - (arity-supports-number? elem n))])) + [(split-syntax-at stx pattern #'(... ...)) + => + (lambda (found) + (syntax-case found [...] + [([pre ... repeat] (... ...) [count post ... . tail]) + (and (identifier? #'repeat) + (exact-nonnegative-integer? (syntax-e #'count))) + (build-list + (add1 (syntax-e #'count)) + (lambda (i) + (with-syntax ([(var ...) + (generate-temporaries + (build-list i (lambda (j) #'repeat)))] + [body expr]) + (list + (syntax/loc pattern (pre ... var ... post ... . tail)) + (syntax/loc expr + (let-syntax ([the-body + (lambda _ + (with-syntax ([(repeat (... ...)) #'(var ...)]) + #'body))]) + the-body))))))] + [(pre mid post) + (raise-syntax-error + #f + "expected ellipsis between identifier and natural number literal" + stx + #'mid)]))] + [else (list (list pattern expr))])) -(define (arity-supports-at-least? arity n) - (cond - [(exact-nonnegative-integer? arity) #f] - [(arity-at-least? arity) (<= (arity-at-least-value arity) n)] - [(list? arity) - (define min-at-least - (for/fold {[min-at-least #f]} {[elem (in-list arity)]} - (cond - [(exact-nonnegative-integer? elem) min-at-least] - [(arity-at-least? elem) - (cond - [(not min-at-least) (arity-at-least-value elem)] - [else (min min-at-least (arity-at-least-value elem))])]))) - (cond - [(not min-at-least) #f] - [else - (for/and {[i (in-range n min-at-least)]} - (arity-supports-number? arity i))])])) - -(define (unchecked-arity-includes? one two) - (cond - [(exact-nonnegative-integer? two) - (arity-supports-number? one two)] - [(arity-at-least? two) - (arity-supports-at-least? one (arity-at-least-value two))] - [(list? two) - (for/and {[elem (in-list two)]} - (unchecked-arity-includes? one elem))])) - -(define (arity-includes? one two) - (unless (procedure-arity? one) - (raise-argument-error 'arity-includes? "procedure-arity?" 0 one two)) - (unless (procedure-arity? two) - (raise-argument-error 'arity-includes? "procedure-arity?" 1 one two)) - (unchecked-arity-includes? one two)) - -(define (arity=? one two) - (unless (procedure-arity? one) - (raise-argument-error 'arity=? "procedure-arity?" 0 one two)) - (unless (procedure-arity? two) - (raise-argument-error 'arity=? "procedure-arity?" 1 one two)) - (and - (unchecked-arity-includes? one two) - (unchecked-arity-includes? two one))) +(define-syntax (case-lambda* stx) + (syntax-case stx [] + [(_ [pattern body] ...) + (with-syntax ([([pattern body] ...) + (append-map + (lambda (p e) (expand-ellipsis-clause stx p e)) + (syntax->list #'(pattern ...)) + (syntax->list #'(body ...)))]) + (syntax/loc stx + (case-lambda [pattern body] ...)))])) diff --git a/racket/collects/racket/private/arity.rkt b/racket/collects/racket/private/arity.rkt new file mode 100644 index 0000000000..88d2404993 --- /dev/null +++ b/racket/collects/racket/private/arity.rkt @@ -0,0 +1,107 @@ +#lang racket/base + +(require racket/private/norm-arity) + +(provide normalize-arity normalized-arity? arity=? arity-includes?) + +(define (normalized-arity? a) + (or (null? a) + (arity? a) + (and (list? a) + ((length a) . >= . 2) + (andmap arity? a) + (if (ormap arity-at-least? a) + (non-empty-non-singleton-sorted-list-ending-with-arity? a) + (non-singleton-non-empty-sorted-list? a))))) + +(define (arity? a) + (or (exact-nonnegative-integer? a) + (and (arity-at-least? a) + (exact-nonnegative-integer? (arity-at-least-value a))))) + +;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean +;; know that 'a' is a list of at least 2 elements +(define (non-empty-non-singleton-sorted-list-ending-with-arity? a) + (let loop ([bound (car a)] + [lst (cdr a)]) + (cond + [(null? (cdr lst)) + (and (arity-at-least? (car lst)) + (> (arity-at-least-value (car lst)) (+ 1 bound)))] + [else + (and (exact-nonnegative-integer? (car lst)) + ((car lst) . > . bound) + (loop (car lst) + (cdr lst)))]))) + +(define (non-empty-sorted-list? a) + (and (pair? a) + (sorted-list? a))) + +(define (non-singleton-non-empty-sorted-list? a) + (and (pair? a) + (pair? (cdr a)) + (sorted-list? a))) + +(define (sorted-list? a) + (or (null? a) + (sorted/bounded-list? (cdr a) (car a)))) + +(define (sorted/bounded-list? a bound) + (or (null? a) + (and (number? (car a)) + (< bound (car a)) + (sorted/bounded-list? (cdr a) (car a))))) + +(define (arity-supports-number? arity n) + (cond + [(exact-nonnegative-integer? arity) (= arity n)] + [(arity-at-least? arity) (<= (arity-at-least-value arity) n)] + [(list? arity) + (for/or {[elem (in-list arity)]} + (arity-supports-number? elem n))])) + +(define (arity-supports-at-least? arity n) + (cond + [(exact-nonnegative-integer? arity) #f] + [(arity-at-least? arity) (<= (arity-at-least-value arity) n)] + [(list? arity) + (define min-at-least + (for/fold {[min-at-least #f]} {[elem (in-list arity)]} + (cond + [(exact-nonnegative-integer? elem) min-at-least] + [(arity-at-least? elem) + (cond + [(not min-at-least) (arity-at-least-value elem)] + [else (min min-at-least (arity-at-least-value elem))])]))) + (cond + [(not min-at-least) #f] + [else + (for/and {[i (in-range n min-at-least)]} + (arity-supports-number? arity i))])])) + +(define (unchecked-arity-includes? one two) + (cond + [(exact-nonnegative-integer? two) + (arity-supports-number? one two)] + [(arity-at-least? two) + (arity-supports-at-least? one (arity-at-least-value two))] + [(list? two) + (for/and {[elem (in-list two)]} + (unchecked-arity-includes? one elem))])) + +(define (arity-includes? one two) + (unless (procedure-arity? one) + (raise-argument-error 'arity-includes? "procedure-arity?" 0 one two)) + (unless (procedure-arity? two) + (raise-argument-error 'arity-includes? "procedure-arity?" 1 one two)) + (unchecked-arity-includes? one two)) + +(define (arity=? one two) + (unless (procedure-arity? one) + (raise-argument-error 'arity=? "procedure-arity?" 0 one two)) + (unless (procedure-arity? two) + (raise-argument-error 'arity=? "procedure-arity?" 1 one two)) + (and + (unchecked-arity-includes? one two) + (unchecked-arity-includes? two one))) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index d8540088f7..340c4a6bd2 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -5,7 +5,7 @@ syntax/stx syntax/boundmap) "generic-methods.rkt" - (only-in racket/function arity-includes?)) + (only-in racket/private/arity arity-includes?)) (provide define-primitive-generics define-primitive-generics/derived