1#lang racket/base
2
3(require (for-syntax racket/base racket/list syntax/name)
4         racket/list racket/private/arity)
5
6(provide identity const thunk thunk* negate curry curryr
7         (all-from-out racket/private/arity)
8         conjoin disjoin)
9
10(define (identity x) x)
11
12(define (const c)
13  (define (const . _) c)
14  (make-keyword-procedure const const))
15
16(define-syntax (thunk stx)
17  (syntax-case stx ()
18    [(_ body0 body ...) (syntax/loc stx (lambda () body0 body ...))]))
19
20(define-syntax (thunk* stx)
21  (syntax-case stx ()
22    [(_ body0 body ...)
23     (with-syntax ([proc (syntax-property
24                          (syntax/loc stx
25                            ;; optimize 0- and 1-argument cases
26                            (case-lambda [() body0 body ...]
27                                         [(x) (th)] [xs (th)]))
28                          'inferred-name (syntax-local-infer-name stx))])
29       (syntax/loc stx
30         (letrec ([th proc])
31           (make-keyword-procedure (lambda (_1 _2 . _3) (th)) proc))))]))
32
33(define (negate f)
34  (unless (procedure? f) (raise-argument-error 'negate "procedure?" f))
35  (let-values ([(arity) (procedure-arity f)] [(_ kwds) (procedure-keywords f)])
36    (case (and (null? kwds) arity) ; optimize some simple cases
37      [(0) (lambda () (not (f)))]
38      [(1) (lambda (x) (not (f x)))]
39      [(2) (lambda (x y) (not (f x y)))]
40      [else (compose1 not f)]))) ; keyworded or more args => just compose
41
42(define (make-curry right?)
43  ; arity-mask? -> (or/c exact-nonnegative-integer? +inf.0 #f)
44  ;
45  ; Calculates the maximum number of arguments a function with the given arity may be applied to. If
46  ; an unbounded number of arguments are permitted, returns +inf.0. If no number of arguments is valid
47  ; (that is, the procedure is uninvokable), returns #f.
48  (define (arity-upper-bound mask)
49    (cond
50      [(eqv? mask 0) #f]
51      [(negative? mask) +inf.0]
52      [else (sub1 (integer-length mask))]))
53
54  ; arity-mask? exact-nonnegative-integer? -> arity-mask?
55  ;
56  ; Calculates the positional argument arity for a function produced by `curry` that has already been
57  ; applied to num-args-so-far arguments.
58  (define (partially-applied-procedure-arity-mask mask num-args-so-far)
59    (if (negative? mask)
60        -1
61        (sub1 (arithmetic-shift 1 (- (integer-length mask) num-args-so-far)))))
62
63  (define who (if right? 'curryr 'curry))
64
65  (define incorporate-new-pos-args
66    (if right?
67        (lambda (pos-args-so-far new-pos-args) (append new-pos-args pos-args-so-far))
68        (lambda (pos-args-so-far new-pos-args) (append pos-args-so-far new-pos-args))))
69
70  ;; the actual implementation of curry[r] is here
71  (define (do-curry f)
72    (unless (procedure? f)
73      (raise-argument-error who "procedure?" f))
74    (let*-values ([(name) (object-name f)]
75                  [(curried-name) (if (symbol? name)
76                                      (string->symbol (string-append "curried:"
77                                                                     (symbol->string name)))
78                                      'curried)]
79                  [(arity-mask) (procedure-arity-mask f)]
80                  [(max-arity) (arity-upper-bound arity-mask)]
81                  [(required-kws allowed-kws) (procedure-keywords f)])
82      (cond
83        ;; fast path for functions that don't accept any keywords
84        [(null? allowed-kws)
85         (define (reduce-arity/rename proc num-args-so-far)
86           (procedure-reduce-arity-mask
87            proc
88            (partially-applied-procedure-arity-mask arity-mask num-args-so-far)
89            curried-name))
90
91         (define (make-curried args-so-far)
92           (reduce-arity/rename
93            (lambda new-args
94              (let ([args (incorporate-new-pos-args args-so-far new-args)])
95                (if (procedure-arity-includes? f (length args))
96                    (apply f args)
97                    (make-curried args))))
98            (length args-so-far)))
99
100         (reduce-arity/rename
101          (lambda args
102            (if (= (length args) max-arity)
103                (apply f args)
104                (make-curried args)))
105          0)]
106
107        ;; slow path for functions that accept keywords
108        [else
109         (define (incorporate-new-kws+args kws+args-so-far new-kws+args)
110           (for/fold ([kws+args kws+args-so-far])
111                     ([(kw arg) (in-hash new-kws+args)])
112             (if (hash-has-key? kws+args kw)
113                 (raise-arguments-error
114                  curried-name
115                  "duplicate keyword for procedure"
116                  "keyword" kw
117                  "first value" (hash-ref kws+args kw)
118                  "second value" arg)
119                 (hash-set kws+args kw arg))))
120
121         (define (reduce-arity/rename proc num-args-so-far kw+args-so-far)
122           (procedure-reduce-keyword-arity-mask
123            proc
124            (partially-applied-procedure-arity-mask arity-mask num-args-so-far)
125            '()
126            (and allowed-kws
127                 (filter (lambda (kw) (not (hash-has-key? kw+args-so-far kw))) allowed-kws))
128            curried-name))
129
130         (define (make-curried pos-args-so-far kws+args-so-far)
131           (reduce-arity/rename
132            (make-keyword-procedure
133             (lambda (new-kws new-kw-args . new-pos-args)
134               (step (incorporate-new-pos-args pos-args-so-far new-pos-args)
135                     (incorporate-new-kws+args
136                      kws+args-so-far
137                      (make-immutable-hasheq (map cons new-kws new-kw-args)))))
138             (lambda new-pos-args
139               (step (incorporate-new-pos-args pos-args-so-far new-pos-args) kws+args-so-far)))
140            (length pos-args-so-far)
141            kws+args-so-far))
142
143         ; handles a curried application and applies f if enough arguments have been accumulated,
144         ; otherwise produces a new curried function
145         (define (step pos-args-so-far kw+args-so-far)
146           (if (and (procedure-arity-includes? f (length pos-args-so-far) #t)
147                    (for/and ([required-kw (in-list required-kws)])
148                      (hash-has-key? kw+args-so-far required-kw)))
149               (let* ([sorted-kw+args (sort (hash->list kw+args-so-far) keyword<? #:key car)]
150                      [kws (map car sorted-kw+args)]
151                      [kw-args (map cdr sorted-kw+args)])
152                 (keyword-apply f kws kw-args pos-args-so-far))
153               (make-curried pos-args-so-far kw+args-so-far)))
154
155         (reduce-arity/rename
156          (make-keyword-procedure
157           (lambda (kws kw-args . pos-args)
158             (if (and (= (length pos-args) max-arity)
159                      allowed-kws
160                      ; we're protected by procedure-reduce-arity, so the same number of keywords
161                      ; means the call must be fully-saturated
162                      (= (length kws) (length allowed-kws)))
163                 (keyword-apply f kws kw-args pos-args)
164                 (make-curried pos-args (make-immutable-hasheq (map cons kws kw-args)))))
165           (lambda pos-args
166             ; a non-keyword application can't possibly be fully-saturated, since we're on the keyword
167             ; path, so just produce a curried function
168             (make-curried pos-args #hasheq())))
169          0
170          #hasheq())])))
171
172  ;; curry itself is curried; if we get any args, immediately invoke the curried function with them
173  (procedure-rename
174   (make-keyword-procedure
175    (lambda (kws kw-args f . args)
176      (let ([curried (do-curry f)])
177        (if (null? kws)
178            (if (null? args)
179                curried
180                (apply curried args))
181            (keyword-apply curried kws kw-args args))))
182    (case-lambda
183      [(f) (do-curry f)]
184      [(f . args) (apply (do-curry f) args)]))
185   who))
186
187(define curry  (make-curry #f))
188(define curryr (make-curry #t))
189
190;; Originally from `unstable/function`.
191;; Originally written by Carl Eastlund
192
193;; ryanc: adjusted limit of inner cases from 8 to 2
194;; All uses so far seem to be predicates, so more cases seem
195;; unnecessary. Also, all uses so far are first-order, so
196;; outer case-lambda* might be better replaced with macro.
197
198(define conjoin
199  (case-lambda*
200   [(f ... 8)
201    (begin
202      (for ([f* (in-list (list f ...))])
203        (unless (procedure? f*)
204          (raise-argument-error 'conjoin "procedure?" f*)))
205      (make-intermediate-procedure
206       'conjoined
207       [(x (... ...) 2) (and (f x (... ...)) ...)]
208       [xs (and (apply f xs) ...)]
209       #:keyword
210       [(keys vals . args)
211        (and (keyword-apply f keys vals args) ...)]))]
212   [fs
213    (begin
214      (for ([f* (in-list fs)])
215        (unless (procedure? f*)
216          (raise-argument-error 'conjoin "procedure?" f*)))
217      (make-intermediate-procedure
218       'conjoined
219       [(x ... 2) (andmap (lambda (f) (f x ...)) fs)]
220       [xs (andmap (lambda (f) (apply f xs)) fs)]
221       #:keyword
222       [(keys vals . args)
223        (andmap (lambda (f) (keyword-apply f keys vals args)) fs)]))]))
224
225(define disjoin
226  (case-lambda*
227   [(f ... 8)
228    (begin
229      (for ([f* (in-list (list f ...))])
230        (unless (procedure? f*)
231          (raise-argument-error 'conjoin "procedure?" f*)))
232      (make-intermediate-procedure
233       'disjoined
234       [(x (... ...) 2) (or (f x (... ...)) ...)]
235       [xs (or (apply f xs) ...)]
236       #:keyword
237       [(keys vals . args)
238        (or (keyword-apply f keys vals args) ...)]))]
239   [fs
240    (begin
241      (for ([f* (in-list fs)])
242        (unless (procedure? f*)
243          (raise-argument-error 'conjoin "procedure?" f*)))
244      (make-intermediate-procedure
245       'disjoined
246       [(x ... 2) (ormap (lambda (f) (f x ...)) fs)]
247       [xs (ormap (lambda (f) (apply f xs)) fs)]
248       #:keyword
249       [(keys vals . args)
250        (ormap (lambda (f) (keyword-apply f keys vals args)) fs)]))]))
251
252(define-syntax (make-intermediate-procedure stx)
253  (syntax-case stx [quote]
254    [(_ (quote name) positional-clause ... #:keyword keyword-clause)
255     (syntax/loc stx
256       (make-keyword-procedure
257        (let* ([name (case-lambda keyword-clause)]) name)
258        (let* ([name (case-lambda* positional-clause ...)]) name)))]))
259
260;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
261;;
262;;  Automatic case-lambda repetition
263;;
264;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
265
266(define-for-syntax (split-syntax-at orig stx id)
267  (let loop ([found #f]
268             [seen null]
269             [stx stx])
270    (syntax-case stx []
271      [(head . tail)
272       (and (identifier? #'head)
273            (free-identifier=? #'head id))
274       (if found
275           (raise-syntax-error
276            #f
277            (format "duplicate occurrence of ~a" (syntax-e id))
278            orig
279            #'head)
280           (loop (list (reverse seen) #'head #'tail)
281                 (cons #'head seen)
282                 #'tail))]
283      [(head . tail) (loop found (cons #'head seen) #'tail)]
284      [_ found])))
285
286(define-for-syntax (expand-ellipsis-clause stx pattern expr)
287  (cond
288   [(split-syntax-at stx pattern #'(... ...))
289    =>
290    (lambda (found)
291      (syntax-case found [...]
292        [([pre ... repeat] (... ...) [count post ... . tail])
293         (and (identifier? #'repeat)
294              (exact-nonnegative-integer? (syntax-e #'count)))
295         (build-list
296          (add1 (syntax-e #'count))
297          (lambda (i)
298            (with-syntax ([(var ...)
299                           (generate-temporaries
300                            (build-list i (lambda (j) #'repeat)))]
301                          [body expr])
302              (list
303               (syntax/loc pattern (pre ... var ... post ... . tail))
304               (syntax/loc expr
305                 (let-syntax ([the-body
306                               (lambda _
307                                 (with-syntax ([(repeat (... ...)) #'(var ...)])
308                                   #'body))])
309                   the-body))))))]
310        [(pre mid post)
311         (raise-syntax-error
312          #f
313          "expected ellipsis between identifier and natural number literal"
314          stx
315          #'mid)]))]
316   [else (list (list pattern expr))]))
317
318(define-syntax (case-lambda* stx)
319  (syntax-case stx []
320    [(_ [pattern body] ...)
321     (with-syntax ([([pattern body] ...)
322                    (append-map
323                     (lambda (p e) (expand-ellipsis-clause stx p e))
324                     (syntax->list #'(pattern ...))
325                     (syntax->list #'(body ...)))])
326       (syntax/loc stx
327         (case-lambda [pattern body] ...)))]))
328