Fix currying of higher order functions

diff --git a/curry-tests.scm b/curry-tests.scm
index b5a53a05b7a7f3fc4288a869381a7263736bd432..4d01adb13dc1de91562a51dcb71820a9db820e4e 100644 (file)
--- a/curry-tests.scm
+++ b/curry-tests.scm
@@ -1,35 +1,64 @@
-(define-module (vdc curry)
+(define-module (vdc curry tests)
   #:use-module (vdc curry)
   #:use-module (srfi srfi-64))
 
 (define e (compose primitive-eval expand-cfs))
 
-(test-begin "test-curry")
+(test-begin "curry")
+
+;;;; curry-proc and enhance-cf
+
+(let ((+ (enhance-cf (curry-proc + 3) 3)))
+  (test-equal 6 (+ 1 2 3))
+  (test-equal 6 (((+ 1) 2) 3))
+  (test-equal 6 ((+ 1 2) 3))
+  (test-equal 6 ((+ 1) 2 3))
+  (let ((f (enhance-cf (lambda (f) (f 1)) 3)))
+    (test-equal 6 (f + 2 3))
+    (test-equal 6 ((f + 2) 3))
+    (test-equal 6 (((f +) 2) 3))))
+
+(let* ((f (enhance-cf (curry-proc * 2) 2))
+       (g (enhance-cf (lambda (x) (f x)) 2)))
+  (test-equal 6 (g 2 3))
+  (test-equal 6 ((g 2) 3)))
 
 ;; CF-free expression
 (test-equal 3 (e '(+ 1 2)))
 
 ;; invalid zero variable CF
-(test-error (e '((λp () #t))))
+(test-error (e '((λc () #t))))
 
 ;; unclosed CF
-(test-error (e '(λp (x) x)))
+(test-error (e '(λc (x) x)))
 
 ;; open CF as argument to a CF
-(test-equal 3 (e '((λp (f) (f 2))
-                  ((λp (a b) (+ a b))
+(test-equal 3 (e '((λc (f) (f 2))
+                  ((λc (a b) (+ a b))
                    1))))
 
 ;; CF applied to too many arguments
-(test-error (e '((λp (x) x) 1 2)))
+(test-error (e '((λc (x) x) 1 2)))
 
 ;; open CF as argument to something other than a CF
-(test-error (e '(+ 1 (λp (x) x))))
+(test-error (e '(+ 1 (λc (x) x))))
+
+;; composition
+;; we are going for (∘ * 1+ 1 3) ≡ ((∘ * 1+) 1 3) ≡ (((∘ * 1+) 1) 3) where:
+;; ∘ ≡ (λc (g f) (λc (x) (g (f x))))
+;; * ≡ (λc (x y) (* x y))
+;; and 1+ is the Scheme procedure.
+(test-equal (* (1+ 1) 3)
+  (e '((λc (g f) (λc (x) (g (f x)))) (λc (x y) (* x y)) 1+ 1 3)))
+(test-equal (* (1+ 1) 3)
+  (e '(((λc (g f) (λc (x) (g (f x)))) (λc (x y) (* x y)) 1+) 1 3)))
+(test-equal (* (1+ 1) 3)
+  (e '((((λc (g f) (λc (x) (g (f x)))) (λc (x y) (* x y)) 1+) 1) 3)))
 
 ;; misc
-(test-equal 3 (e '(+ 1 ((λp (x) x) 2))))
-(test-equal 6 (e '((((λp (x y z)
+(test-equal 3 (e '(+ 1 ((λc (x) x) 2))))
+(test-equal 6 (e '((((λc (x y z)
                          (+ x y z))
-                     1) 2) 3)))
+                    1) 2) 3)))
 
-(test-end "test-curry")
+(test-end "curry")

diff --git a/curry.scm b/curry.scm
index cb533af884fabf96549a5621c5f7018dae2bed11..c1b5fc2479f71d726dbef14db0e626d6cc751318 100644 (file)
--- a/curry.scm
+++ b/curry.scm
@@ -1,9 +1,9 @@
 ;;;; The following code adds syntax for creating and partially applying curried
 ;;;; functions (CFs) in Scheme. The code also raise errors, at syntax expansion
 ;;;; time, if CFs aren't applied properly. A simple valid use case is as follow:
-;;;;     (((λp (x y z) (+ x y z)) 1 2) 3)
+;;;;     (((λc (x y z) (+ x y z)) 1 2) 3)
 ;;;; while the following raises an error:
-;;;;     ((λp (x) x) 1 2)
+;;;;     ((λc (x) x) 1 2)
 ;;;; See "partial-tests.scm" for more examples and continue reading for
 ;;;; implementation details.
 ;;;;
@@ -11,7 +11,7 @@
 ;;;; (RMANA) is associated to it. The RMANA decreases as the CF gets applied
 ;;;; and, when it reaches zero, it can no longer be applied. The system also
 ;;;; associates `#f' RMANA to Scheme expressions that can't be partially
-;;;; applied.We say that an expression is closed when its RMANA is false or zero
+;;;; applied. We say that an expression is closed when its RMANA is false or zero
 ;;;; and opened otherwise. The distinction between expressions with false vs
 ;;;; zero RMANA is that the former is applicable to any number of closed
 ;;;; argument while the latter can't be applied at  all. The system verifies
@@ -25,13 +25,15 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 receive)
   #:export
-  (expand-cfs))
+  (curry-proc
+   enhance-cf
+   expand-cfs))
 
 (define (bind-var bindings var val)
   (assoc-set! bindings var val))
 
 (define (bind-vars bindings vars vals)
-  (fold bind-var bindings vars vals))
+  (fold (lambda (x y prev) (bind-var prev x y)) bindings vars vals))
 
 (define (closed? x)
   (or (not x)
@@ -39,6 +41,25 @@
 
 (define opened? (compose not closed?))
 
+(define (curry-proc proc n)
+  (let curry ((n n)
+             (stack '()))
+    (if (= 0 n)
+       (apply proc (reverse stack))
+       (lambda (x)
+         (curry (1- n)
+                (cons x stack))))))
+
+(define (enhance-cf f n)
+  (lambda (x . xs)
+    (let ((r (- n 1 (length xs))))
+      ((if (= 0 r)
+          identity
+          (lambda (x) (enhance-cf x r)))
+       (fold (lambda (x prev)
+              (prev x))
+            (f x) xs)))))
+
 (define* (preturn expr_ m #:optional ns)
   "Return an expanded expression and it's RMANA or throw an error if we are
 trying to apply it to too many. `expr_' is an expanded expression, `m' its
@@ -49,7 +70,7 @@ RMANA, and `ns' the RMANAs of the applied arguments, if any."
     ((and (not m) ns (any opened? ns))
      (error "non-CFs can't be applied to opened CFs."))
     ((and m ns (< m (length ns)))
-     (error "too many arguments."))
+     (error "too many arguments." expr_ m ns))
     ((and m ns)
      (- m (length ns)))
     (else m))))
@@ -58,13 +79,16 @@ RMANA, and `ns' the RMANAs of the applied arguments, if any."
   (define (it x args bindings)
     (match
        x
-      (('λp (vars ..1) body)
-       (let ((body_ n (it body '() (bind-vars bindings vars args))))
-         (preturn
-          `(enhance-proc (lambda ,vars ,body_)
-                         ,(length vars))
-          (or (and n (+ n (length vars)))
-              (length vars)))))
+      (('λc (vars ..1) body)
+       (let* ((body_ n (it body '() (bind-vars bindings vars args)))
+             (m (length vars))
+             (rmana (or (and n (+ n m))
+                        m)))
+        (preturn
+          `(enhance-cf (curry-proc (lambda ,vars ,body_)
+                                  ,m)
+                      ,rmana)
+         rmana)))
       ((f as ...)
        (let* ((as (map
                    (lambda (a)
@@ -73,7 +97,7 @@ RMANA, and `ns' the RMANAs of the applied arguments, if any."
               (as_ asn (unzip2 as))
               (f_ fn (if-let
                       (x (assoc-ref bindings f))
-                      (values (first x) (second x))
+                      (values f (second x))
                       (it f as bindings))))
          (preturn (cons f_ as_)
                   fn asn)))

diff --git a/misc.scm b/misc.scm
new file mode 100644 (file)
index 0000000..efbaa78
--- /dev/null
+++ b/misc.scm
@@ -0,0 +1,12 @@
+(define-module (vdc misc)
+  #:export
+  (if-let))
+
+(define-syntax if-let
+  (syntax-rules ()
+    [(_ (x test) consequent alternate)
+     (let ([x test])
+       (if x consequent alternate))]
+    [(_ (x test) consequent)
+     (let ([x test])
+       (if x consequent))]))