Coverage report: /home/ellis/comp/core/std/curry.lisp

KindCoveredAll%
expression52183 28.4
branch216 12.5
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/curry.lisp --- Standard Currying Functions
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :std/curry)
7
 
8
 ;;; Alexandria Functions
9
 (declaim (ftype (function (t) (values function &optional))
10
                 ensure-function)
11
          (inline ensure-function))
12
 (defun ensure-function (function-designator)
13
   "Returns the function designated by FUNCTION-DESIGNATOR:
14
 if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
15
 it must be a function name and its FDEFINITION is returned."
16
   (if (functionp function-designator)
17
       function-designator
18
       (fdefinition function-designator)))
19
 
20
 (define-modify-macro ensure-functionf/1 () ensure-function)
21
 
22
 (defmacro ensure-functionf (&rest places)
23
   "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
24
 PLACES contains a function."
25
   `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
26
 
27
 (defun disjoin (predicate &rest more-predicates)
28
   "Returns a function that applies each of PREDICATE and MORE-PREDICATE
29
 functions in turn to its arguments, returning the primary value of the first
30
 predicate that returns true, without calling the remaining predicates.
31
 If none of the predicates returns true, NIL is returned."
32
   (declare (optimize (speed 3) (safety 1) (debug 1)))
33
   (let ((predicate (ensure-function predicate))
34
         (more-predicates (mapcar #'ensure-function more-predicates)))
35
     (lambda (&rest arguments)
36
       (or (apply predicate arguments)
37
           (some (lambda (p)
38
                   (declare (type function p))
39
                   (apply p arguments))
40
                 more-predicates)))))
41
 
42
 (defun conjoin (predicate &rest more-predicates)
43
   "Returns a function that applies each of PREDICATE and MORE-PREDICATE
44
 functions in turn to its arguments, returning NIL if any of the predicates
45
 returns false, without calling the remaining predicates. If none of the
46
 predicates returns false, returns the primary value of the last predicate."
47
   (if (null more-predicates)
48
       predicate
49
       (lambda (&rest arguments)
50
         (and (apply predicate arguments)
51
              ;; Cannot simply use CL:EVERY because we want to return the
52
              ;; non-NIL value of the last predicate if all succeed.
53
              (do ((tail (cdr more-predicates) (cdr tail))
54
                   (head (car more-predicates) (car tail)))
55
                  ((not tail)
56
                   (apply head arguments))
57
                (unless (apply head arguments)
58
                  (return nil)))))))
59
 
60
 (defun compose (function &rest more-functions)
61
   "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
62
 arguments to each in turn, starting from the rightmost of MORE-FUNCTIONS,
63
 and then calling the next one with the primary value of the last."
64
   (declare (optimize (speed 3) (safety 1) (debug 1)))
65
   (reduce (lambda (f g)
66
             (let ((f (ensure-function f))
67
                   (g (ensure-function g)))
68
               (lambda (&rest arguments)
69
                 (declare (dynamic-extent arguments))
70
                 (funcall f (apply g arguments)))))
71
           more-functions
72
           :initial-value function))
73
 
74
 (define-compiler-macro compose (function &rest more-functions)
75
   (labels ((compose-1 (funs)
76
              (if (cdr funs)
77
                  `(funcall ,(car funs) ,(compose-1 (cdr funs)))
78
                  `(apply ,(car funs) arguments))))
79
     (let* ((args (cons function more-functions))
80
            (funs (make-gensym-list (length args) "COMPOSE")))
81
       `(let ,(loop for f in funs for arg in args
82
                    collect `(,f (ensure-function ,arg)))
83
          (declare (optimize (speed 3) (safety 1) (debug 1)))
84
          (lambda (&rest arguments)
85
            (declare (dynamic-extent arguments))
86
            ,(compose-1 funs))))))
87
 
88
 (defun multiple-value-compose (function &rest more-functions)
89
     "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
90
 its arguments to each in turn, starting from the rightmost of
91
 MORE-FUNCTIONS, and then calling the next one with all the return values of
92
 the last."
93
   (declare (optimize (speed 3) (safety 1) (debug 1)))
94
   (reduce (lambda (f g)
95
             (let ((f (ensure-function f))
96
                   (g (ensure-function g)))
97
               (lambda (&rest arguments)
98
                 (declare (dynamic-extent arguments))
99
                 (multiple-value-call f (apply g arguments)))))
100
           more-functions
101
           :initial-value function))
102
 
103
 (define-compiler-macro multiple-value-compose (function &rest more-functions)
104
   (labels ((compose-1 (funs)
105
              (if (cdr funs)
106
                  `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
107
                  `(apply ,(car funs) arguments))))
108
     (let* ((args (cons function more-functions))
109
            (funs (make-gensym-list (length args) "MV-COMPOSE")))
110
       `(let ,(mapcar #'list funs args)
111
          (declare (optimize (speed 3) (safety 1) (debug 1)))
112
          (lambda (&rest arguments)
113
            (declare (dynamic-extent arguments))
114
            ,(compose-1 funs))))))
115
 
116
 (declaim (inline curry rcurry))
117
 
118
 (defun curry (function &rest arguments)
119
   "Returns a function that applies ARGUMENTS and the arguments
120
 it is called with to FUNCTION."
121
   (declare (optimize (speed 3) (safety 1)))
122
   (let ((fn (ensure-function function)))
123
     (lambda (&rest more)
124
       (declare (dynamic-extent more))
125
       ;; Using M-V-C we don't need to append the arguments.
126
       (multiple-value-call fn (values-list arguments) (values-list more)))))
127
 
128
 (define-compiler-macro curry (function &rest arguments)
129
   (let ((curries (make-gensym-list (length arguments) "CURRY"))
130
         (fun (gensym "FUN")))
131
     `(let ((,fun (ensure-function ,function))
132
            ,@(mapcar #'list curries arguments))
133
        (declare (optimize (speed 3) (safety 1)))
134
        (lambda (&rest more)
135
          (declare (dynamic-extent more))
136
          (apply ,fun ,@curries more)))))
137
 
138
 (defun rcurry (function &rest arguments)
139
   "Returns a function that applies the arguments it is called
140
 with and ARGUMENTS to FUNCTION."
141
   (declare (optimize (speed 3) (safety 1)))
142
   (let ((fn (ensure-function function)))
143
     (lambda (&rest more)
144
       (declare (dynamic-extent more))
145
       (multiple-value-call fn (values-list more) (values-list arguments)))))
146
 
147
 (define-compiler-macro rcurry (function &rest arguments)
148
   (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
149
         (fun (gensym "FUN")))
150
     `(let ((,fun (ensure-function ,function))
151
            ,@(mapcar #'list rcurries arguments))
152
        (declare (optimize (speed 3) (safety 1)))
153
        (lambda (&rest more)
154
          (declare (dynamic-extent more))
155
          (multiple-value-call ,fun (values-list more) ,@rcurries)))))
156
 
157
 (declaim (notinline curry rcurry))
158
 
159
 (defun map-product (fn list &rest more-lists)                   
160
   (labels ((%map-product (f lists)                              
161
              (let ((more (cdr lists))                           
162
                    (one (car lists)))                           
163
                (if (not more)                                   
164
                    (mapcar f one)                               
165
                    (mappend (lambda (x)                         
166
                               (%map-product (curry f x) more))  
167
                             one)))))                            
168
     (%map-product (ensure-function fn) (cons list more-lists))))