Add the currying macro FN*.

darcs-hash:648154b9e02a3eb3f22bde685dd220d7ac8b6e89

3 files changed, 61 insertions, 37 deletions

diff --git a/lambda.lisp b/lambda.lisp
index e6c60dd..2f90aa2 100644
--- a/lambda.lisp
+++ b/lambda.lisp
@@ -34,12 +34,20 @@
  | (funcall (efn1 (efn1 _)))             ;=> #<LAMBDA ...>  ; new!
  | (funcall (fn1 _3) 1 2 3 4 5)          ;=> 4
  | (funcall (efn1 _3) 1 2 3 4 5)         ;=> error
+ |
+ |
+ | Currying variant FN* (cf. LIST vs. LIST*)
+ | =========================================
+ |
+ | (funcall (fn* #'+ 1) 2)               ;=> 3
+ | (funcall (fn* #'+) 1 2)               ;=> 3
+ | (funcall (fn* (/ (* _ 4))) 3 6)       ;=> 2
  |#
 
 
 (defpackage #:mulk.lambda
   (:use #:cl)
-  (:export #:efn #:fn #:efn1 #:fn1))
+  (:export #:efn #:fn #:efn1 #:fn1 #:fn*))
 (in-package #:mulk.lambda)
 
 
@@ -99,6 +107,16 @@ removed symbol (if found)."
           (find   "_" lambda-args :key #'symbol-name :test #'string=)))
 
 
+(defun build-fn-form (forms form-builder)
+  (let ((lambda-args (find-lambda-args `(progn ,@forms))))
+    (multiple-value-bind (real-lambda-args _)
+        (normalise-lambda-args lambda-args)
+      `(symbol-macrolet ,(if _
+                             `((,_ ,(first real-lambda-args)))
+                             nil)
+         ,(funcall form-builder real-lambda-args)))))
+
+
 (defmacro efn (function-or-form &rest args)
   "A convenience wrapper for LAMBDA.
 
@@ -107,19 +125,12 @@ format string \"_~D\".  _ can be used as an abbreviation for _0."
   (cond ((or (not (listp function-or-form))
              (eq 'function (first function-or-form)))
          `(efn (funcall ,function-or-form ,@args)))
-        (t
-         (let ((lambda-args      (find-lambda-args `(progn
-                                                      ,function-or-form
-                                                      ,@args))))
-           (multiple-value-bind (real-lambda-args _)
-               (normalise-lambda-args lambda-args)
-             `(symbol-macrolet ,(if _
-                                    `((,_ ,(first real-lambda-args)))
-                                    nil)
-                (function (lambda ,real-lambda-args
-                  (declare (ignorable ,@real-lambda-args))
-                  ,function-or-form
-                  ,@args))))))))
+        (t (build-fn-form (list* function-or-form args)
+                          #'(lambda (real-lambda-args)
+                              `(function (lambda ,real-lambda-args
+                                 (declare (ignorable ,@real-lambda-args))
+                                 ,function-or-form
+                                 ,@args)))))))
 
 
 (defmacro fn (function-or-form &rest args)
@@ -130,24 +141,35 @@ produces do not check the number of their arguments."
   (cond ((or (not (listp function-or-form))
              (eq 'function (first function-or-form)))
          `(fn (funcall ,function-or-form ,@args)))
-        (t
-         (let ((lambda-args      (find-lambda-args `(progn
-                                                      ,function-or-form
-                                                      ,@args)))
-               (args-sym         (gensym "FN-ARGS")))
-           (multiple-value-bind (real-lambda-args _)
-               (normalise-lambda-args lambda-args)
-             `(symbol-macrolet (,@(if _
-                                      `((,_ ,(first real-lambda-args)))
-                                      nil)
-                                ,@(loop for i from 0
-                                        for lambda-arg in real-lambda-args
-                                        collect `(,lambda-arg
-                                                  (nth ,i ,args-sym))))
-                (function (lambda (&rest ,args-sym)
-                  (declare (ignorable ,args-sym))
-                  ,function-or-form
-                  ,@args))))))))
+        (t (build-fn-form
+            (list* function-or-form args)
+            #'(lambda (real-lambda-args)
+                (let ((args-sym (gensym "FN-ARGS")))
+                  `(symbol-macrolet (,@(loop for i from 0
+                                             for lambda-arg in real-lambda-args
+                                             collect `(,lambda-arg
+                                                       (nth ,i ,args-sym))))
+                     (function (lambda (&rest ,args-sym)
+                       (declare (ignorable ,args-sym))
+                       ,function-or-form
+                       ,@args)))))))))
+
+
+(defmacro fn* (function-or-form &rest args)
+  "A currying variant of FN.
+
+(FN* (* 2 (+ _ 2))) is equivalent to (LAMBDA (X &REST ARGS)
+                                       (APPLY #'* 2 (+ X 2) ARGS))."
+  (cond ((and (listp function-or-form)
+              (not (eq 'function (first function-or-form))))
+         `(fn* (function ,(first function-or-form))
+               ,@(rest function-or-form)))
+        (t (let ((rest-sym (gensym "ARGS-REST")))
+             (build-fn-form (list* function-or-form args)
+                            #'(lambda (real-lambda-args)
+                                `(function (lambda (,@real-lambda-args &rest ,rest-sym)
+                                   (declare (ignorable ,@real-lambda-args))
+                                   (apply ,function-or-form ,@args ,rest-sym)))))))))
 
 
 (defmacro efn1 (value-or-form &rest forms)
@@ -160,7 +182,7 @@ produces do not check the number of their arguments."
   (cond ((or (not (listp value-or-form))
              (eq 'function (first value-or-form)))
          `(efn () ,value-or-form ,@forms))
-        (t                           `(efn ,value-or-form ,@forms))))
+        (t `(efn ,value-or-form ,@forms))))
 
 
 (defmacro fn1 (value-or-form &rest forms)
@@ -173,4 +195,4 @@ produces do not check the number of their arguments."
   (cond ((or (not (listp value-or-form))
              (eq 'function (first value-or-form)))
          `(fn () ,value-or-form ,@forms))
-        (t                           `(fn ,value-or-form ,@forms))))
+        (t `(fn ,value-or-form ,@forms))))
diff --git a/mulkutils.asd b/mulkutils.asd
index 767a0d9..1f80267 100644
--- a/mulkutils.asd
+++ b/mulkutils.asd
@@ -1,6 +1,6 @@
 (defsystem "mulkutils"
   :description "Random utilities by Matthias Benkard."
-  :version "0.1.0"
+  :version "0.2.0"
   :author "Matthias Benkard <matthias@benkard.de>"
   :licence "GNU General Public License, version 2 or higher"
   :depends-on (:arnesi)
diff --git a/tests.lisp b/tests.lisp
index e106f34..08b3929 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -3,6 +3,10 @@
 (in-package #:mulk.tests)
 
 
+(defun run-all-tests ()
+  (run-tests :suite 'mulk-lambda ))
+
+
 (deftestsuite mulk-lambda ()
   ())
 
@@ -55,7 +59,6 @@
 
 (deftestsuite mulk-lambda-fn* (mulk-lambda)
   ()
-  #+nil
   (:tests
    ((ensure-same (funcall (fn* #'+ 1) 2)
                  3))
@@ -63,4 +66,3 @@
                  3))
    ((ensure-same (funcall (fn* (/ (* _ 4))) 3 6)
                  2))))
-