Expand curried functions and check for errors

diff --git a/curry-tests.scm b/curry-tests.scm
new file mode 100644 (file)
index 0000000..b5a53a0
--- /dev/null
+++ b/curry-tests.scm
@@ -0,0 +1,35 @@
+(define-module (vdc curry)
+  #:use-module (vdc curry)
+  #:use-module (srfi srfi-64))
+
+(define e (compose primitive-eval expand-cfs))
+
+(test-begin "test-curry")
+
+;; CF-free expression
+(test-equal 3 (e '(+ 1 2)))
+
+;; invalid zero variable CF
+(test-error (e '((λp () #t))))
+
+;; unclosed CF
+(test-error (e '(λp (x) x)))
+
+;; open CF as argument to a CF
+(test-equal 3 (e '((λp (f) (f 2))
+                  ((λp (a b) (+ a b))
+                   1))))
+
+;; CF applied to too many arguments
+(test-error (e '((λp (x) x) 1 2)))
+
+;; open CF as argument to something other than a CF
+(test-error (e '(+ 1 (λp (x) x))))
+
+;; misc
+(test-equal 3 (e '(+ 1 ((λp (x) x) 2))))
+(test-equal 6 (e '((((λp (x y z)
+                         (+ x y z))
+                     1) 2) 3)))
+
+(test-end "test-curry")

diff --git a/curry.scm b/curry.scm
new file mode 100644 (file)
index 0000000..cb533af
--- /dev/null
+++ b/curry.scm
@@ -0,0 +1,86 @@
+;;;; 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)
+;;;; while the following raises an error:
+;;;;     ((λp (x) x) 1 2)
+;;;; See "partial-tests.scm" for more examples and continue reading for
+;;;; implementation details.
+;;;;
+;;;; When a CF is created, a remaining maximum applicable number of arguments
+;;;; (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
+;;;; 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
+;;;; that CFs aren't (both immediately and ultimately) applied to too many
+;;;; arguments and that all CFs are ultimately closed.
+
+(define-module (vdc curry)
+  #:use-module (vdc misc)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:export
+  (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))
+
+(define (closed? x)
+  (or (not x)
+      (zero? x)))
+
+(define opened? (compose not closed?))
+
+(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
+RMANA, and `ns' the RMANAs of the applied arguments, if any."
+  (values
+   expr_
+   (cond
+    ((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."))
+    ((and m ns)
+     (- m (length ns)))
+    (else m))))
+
+(define (expand-cfs x)
+  (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)))))
+      ((f as ...)
+       (let* ((as (map
+                   (lambda (a)
+                     (receive vals (it a '() bindings) vals))
+                   as))
+              (as_ asn (unzip2 as))
+              (f_ fn (if-let
+                      (x (assoc-ref bindings f))
+                      (values (first x) (second x))
+                      (it f as bindings))))
+         (preturn (cons f_ as_)
+                  fn asn)))
+      ((? (compose not list?) x)
+       (preturn x #f))
+      (else (error "no matching pattern in partial expanssion."))))
+  (let ((expr_ rmana (it x '() '())))
+    (if (closed? rmana)
+       expr_
+       (error "opened CF in expression."))))