Commits

llibra committed 3d11ad7

Introduce CL-FN.SAPPLY:SEQUENTIALLY-APPLY.

For sequential function application. Inspired by OCaml's %revapply and Yoshinori
Tahara's progs (http://read-eval-print.blogspot.jp/2011/02/progs.html).

(sequentially-apply (- 5 1) (* 4 _) (+ 1 _))

is equivalent to

(+ 1 (* 4 (- 5 1)))

  • Participants
  • Parent commits e5bcfa8

Comments (0)

Files changed (6)

   :serial t
   :components ((:file "packages")
                (:file "cl-fn")))
+
+(defsystem :cl-fn-test
+  :depends-on (:cl-fn :fiveam)
+  :components ((:module "t"
+                        :serial t
+                        :components ((:file "packages")
+                                     (:file "suites")
+                                     (:file "sapply")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :cl-fn))))
+  (asdf:load-system :cl-fn-test)
+  (funcall (intern "RUN!" :5am) (intern "ALL" :cl-fn.test)))
   #'(lambda (&rest args2)
       (apply fn (append args2 args))))
 
+(in-package :cl-fn.sapply)
+
+(defun _->gensym (form)
+  (labels ((_p (x) (and (symbolp x) (string= x "_")))
+           (rec (expr syms)
+             (if (consp expr)
+                 (destructuring-bind (x . xs) expr
+                   (multiple-value-bind (x syms) (rec x syms)
+                     (multiple-value-bind (xs syms) (rec xs syms)
+                       (values (cons x xs) syms))))
+                 (if (_p expr)
+                     (let ((s (gensym)))
+                       (values s (cons s syms)))
+                     (values expr syms)))))
+    (multiple-value-bind (form syms) (rec form nil)
+      (values form (nreverse syms)))))
+
+(defmacro sequentially-apply (form &body body)
+  (if body
+      (destructuring-bind (next . body) body
+        (multiple-value-bind (next syms) (_->gensym next)
+          (if syms
+              `(multiple-value-bind ,syms ,form
+                 (sequentially-apply ,next ,@body))
+              `(progn ,form (sequentially-apply ,next ,@body)))))
+      form))
+
 (in-package :cl-fn.flip)
 
 (defun flip (fn x y)
   (:use :cl)
   (:export :curry :rcurry))
 
+(defpackage :cl-fn.sapply
+  (:use :cl)
+  (:export :sequentially-apply))
+
 (defpackage :cl-fn.flip
   (:use :cl)
   (:export :flip))
 
 (defpackage :cl-fn
-  (:use :cl :cl-fn.fn :cl-fn.alias :cl-fn.comp :cl-fn.pa :cl-fn.flip)
-  (:export :fn :defalias :compose :conjoin :disjoin :curry :rcurry :flip))
+  (:use :cl :cl-fn.fn :cl-fn.alias :cl-fn.comp :cl-fn.pa :cl-fn.sapply
+        :cl-fn.flip)
+  (:export :fn :defalias :compose :conjoin :disjoin :curry :rcurry
+           :sequentially-apply :flip))
+(in-package :cl-user)
+
+(defpackage :cl-fn.test
+  (:use :cl :cl-fn)
+  (:export :all :sapply))
+(in-package :cl-fn.test)
+
+(5am:in-suite sapply)
+
+(5am:test sapply/sequentially-apply
+  (5am:is (eq t (sequentially-apply t)))
+  (5am:is (= 0 (sequentially-apply 0)))
+  (5am:is (= 0 (sequentially-apply (values 0))))
+  (5am:is (eq t (sequentially-apply :ignored t)))
+  (5am:is (eq t (sequentially-apply :ignored (values t))))
+  (5am:is (eq t (sequentially-apply t _)))
+  (5am:is (= 0 (sequentially-apply 0 _)))
+  (5am:is (eq t (sequentially-apply t (identity _))))
+  (5am:is (= 0 (sequentially-apply 0 (identity _))))
+  (5am:is (= 2 (sequentially-apply 0 (1+ _) (1+ _))))
+  (5am:is (= 8 (sequentially-apply 1 (- 5 _) (* _ 2))))
+  (5am:is (equal '(0 1)
+                 (multiple-value-list (sequentially-apply (values 0 1)))))
+  (5am:is (equal '(0 1)
+                 (sequentially-apply (values 0 1)
+                   (list _ _)))))
+(in-package :cl-fn.test)
+
+(5am:def-suite all)
+(5am:def-suite sapply :in all)