Expand partial applications when needed

diff --git a/curry-tests.scm b/curry-tests.scm
index 16ece85ebc2c8c18f1abd1f8d159d72c1489b352..57c718270ed9a4563e79f7084ca56b29d7b9619a 100644 (file)
--- a/curry-tests.scm
+++ b/curry-tests.scm
@@ -1,6 +1,7 @@
 (define-module (vdc curry tests)
   #:use-module (vdc curry)
-  #:use-module (srfi srfi-64))
+  #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-71))
 
 (test-begin "curry")
 ;; TODO: map the reduxtab to a bare version for unit-testing
@@ -11,53 +12,74 @@
 ;;      (compare
 ;;       (parse '(1       . (2 . 3)))
 ;;       (parse '((1 . 2) . (1 . 1))))))
-(test-equal '(1 . 1)
-  (t '() '(λc x x)))
-(test-equal '((3 . 4) . ((2 . 3) . (2 . 4)))
-  (t '() '(λc g (λc f (λc x (g (f x)))))))
-(test-equal 0
-  (t '() '((λc x x) #t)))
+
+(define-syntax-rule (test-type given expected-bare)
+  (test-assert (equal-types? given (parse expected-bare))))
+
+(let ((t e (expand '() '(λc x x))))
+  (test-type t '(1 . 1))
+  (test-equal '(lambda (x) x) e))
+(let ((t e (expand '() '(λc g (λc f (λc x (g (f x))))))))
+  (test-type t '((3 . 4) . ((2 . 3) . (2 . 4))))
+  (test-equal '(lambda (g) (lambda (f) (lambda (x) (g (f x))))) e))
+(let ((t e (expand '() '((λc x x) #t))))
+  (test-type t 0)
+  (test-equal #t (primitive-eval e)))
 (let ((bindings `((id  . ,(parse '(1 . 1)))
                  (∘   . ,(parse '((2 . 3) . ((1 . 2) . (1 . 3)))))
                  (⊙   . ,(parse '((1 . 2) . ((2 . 3) . (1 . 3)))))
                  (map . ,(parse '((0 . 0) . (0 . 0))))
                  (+   . ,(parse '(0 . (0 . 0)))))))
-  (test-equal '(7 . 7)
-    (t bindings '(∘ id id)))
-  (test-equal 0
-    (t bindings '((∘ id id) #t)))
-  (test-equal 0
-    (t bindings '(∘ id id #t)))
-  (test-equal 0
-    (t bindings '(map (+ 1) '(1 2 3))))
-  (test-equal '((9 . 0) . (9 . (0 . 0)))
-    (t bindings '(∘ +)))
-  (test-equal 0
-    (t bindings '((∘ +) (+ 1) 2 3)))
-  (test-equal 0
-    (t bindings '((∘ + (+ 1)) 2 3)))
-  (test-equal 0
-    (t bindings '(((∘ + (+ 1)) 2) 3)))
-  (test-equal 0
-    (t bindings '((∘ (∘ (+ 1)) +) 2 3)))
-  (test-equal 0
-    (t bindings '((∘ (⊙ (+ 1)) +) 2 3)))
-  )
+  (let ((t e (expand bindings '(∘ id id))))
+    (test-type t '(7 . 7))
+    (test-equal e '((∘ id) id)))
+  (let ((t e (expand bindings '((∘ id id) #t))))
+    (test-type t 0)
+    (test-equal e '(((∘ id) id) #t)))
+  (let ((t e (expand bindings '(∘ id id #t))))
+    (test-type t 0)
+    (test-equal e '(((∘ id) id) #t)))
+  (let ((t e (expand bindings '(map (+ 1) '(1 2 3)))))
+    (test-type t 0)
+    (test-equal e '((map (+ 1)) '(1 2 3))))
+  (let ((t e (expand bindings '(∘ +))))
+    (test-type t '((1 . 0) . (1 . (0 . 0))))
+    (test-equal e '(∘ +)))
+  (let ((t e (expand bindings '((∘ +) (+ 1) 2 3))))
+    (test-type t 0)
+    (test-equal e '((((∘ +) (+ 1)) 2) 3)))
+  (let ((t e (expand bindings '((∘ + (+ 1)) 2 3))))
+    (test-type t 0)
+    (test-equal e '((((∘ +) (+ 1)) 2) 3)))
+  (let ((t e (expand bindings '(((∘ + (+ 1)) 2) 3))))
+    (test-type t 0)
+    (test-equal e '((((∘ +) (+ 1)) 2) 3)))
+  (let ((t e (expand bindings '((∘ (∘ (+ 1)) +) 2 3))))
+    (test-type t 0)
+    (test-equal e '((((∘ (∘ (+ 1))) +) 2) 3)))
+  (let ((t e (expand bindings '((∘ (⊙ (+ 1)) +) 2 3))))
+    (test-type t 0)
+    (test-equal e '((((∘ (⊙ (+ 1))) +) 2) 3))))
 
 ;;; interaction between typed and untyped (regular) scheme
 
 ;; Untyped scheme produces untyped return.
-(test-assert (not (t '() '(+ 1 2 3))))
+(let ((t e (expand '() '(+ 1 2 3))))
+  (test-type t #f)
+  (test-equal e '(+ 1 2 3)))
 
 (let ((bindings `((* . ,(parse '(0 . (0 . 0)))))))
   ;; Typed Scheme can be used by untyped Scheme...
-  (test-assert (not (t bindings '(+ 1 (* 2 3) 4))))
+  (let ((t e (expand bindings '(+ 1 (* 2 3) 4))))
+    (test-type t #f)
+    (test-equal e '(+ 1 ((* 2) 3) 4)))
 
   ;; ... although, sometimes, with terrible runtime consequences!
-  (test-assert (not (t bindings '(+ 1 (* 2) 3))))
+  (let ((t e (expand bindings '(+ 1 (* 2) 3))))
+    (test-type t #f)
+    (test-equal e '(+ 1 (* 2) 3)))
 
   ;; On the other hand, typed Scheme expects typed Scheme.
-  (test-error (t bindings '(* 1 (+ 2 3))))
-  )
+  (test-error (expand bindings '(* 1 (+ 2 3)))))
 
 (test-end "curry")

diff --git a/curry.scm b/curry.scm
index af7c14d8ca87f567087896b2425d3ed538282394..77489c4acfe73fd41e51f9aa62776c7028c968dc 100644 (file)
--- a/curry.scm
+++ b/curry.scm
@@ -1,19 +1,21 @@
 (define-module (vdc curry)
   #:use-module ((ice-9 curried-definitions) :prefix c)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-71)
   #:use-module (vdc misc)
   #:replace
   (;(vdc:define . define)
    ;(vdc:primitive-eval . primitive-eval)
    )
   #:export
-  (curry
+  (equal-types?
+   expand
    parse
    symtab
-   t
    ∷))
 
 (define symtab '())
@@ -236,50 +238,65 @@
 (define (sym-set symtab sym value)
   (sym-set! (alist-copy symtab) sym value))
 
-(define (t% symtab expr)
+(define (expand symtab expr)
   (match expr
     (('quote x)
-     (make-node 0))
+     (values
+      (make-node 0)
+      `',x))
     (('λc (? symbol? var) body)
      (let ((var-node (make-node #f)))
-       (let ((nbody (t% (sym-set symtab var var-node)
-                       body)))
-        (unless nbody
+       (let ((bodyt bodye (expand (sym-set symtab var var-node)
+                                 body)))
+        (unless bodyt
           (type-error 5 "in body of" `(λc ,var ,body)))
         (populate-tvs! var-node)
-        (make-node
-         (cons var-node nbody)))))
+        (values
+         (make-node
+          (cons var-node bodyt))
+         `(lambda (,var) ,bodye)))))
     (('letrecc1 ((? symbol? name) expr) body)
      (type-error 0 'letrecc1 name expr body))
     ((f)
-     (if (t% symtab f)
-        (type-error 3 expr)
-        #f))
+     (let ((t e (expand symtab f)))
+       (values
+       (if t
+           (type-error 3 expr)
+           #f)
+       `(,e))))
     ((f as ..1)
-     (if-let (ft (t% symtab f))
-            (fold
-             (lambda (a prev)
-               (apply-1 prev (or (t% symtab a) (type-error 5 f a))))
-             ft as)
-            (begin
-              (for-each
-               (lambda (a)
-                 (t% symtab a))
-               as)
-              #f)))
+     (let ((ft fe (expand symtab f))
+          (ats aes (unzip2
+                    (map
+                     (lambda (a)
+                       (receive vals (expand symtab a) vals))
+                     as))))
+       (if (not ft)
+          (values #f `(,fe ,@aes))
+          (values
+           (fold
+            (lambda (at a prev)
+              (apply-1 prev (or at (type-error 5 f a))))
+            ft ats as)
+           (fold
+            (lambda (ae prev)
+              (list prev ae))
+            fe aes)))))
     (x
-     (if (symbol? x)
-        (sym-ref symtab x)
-        (make-node 0)))))
+     (values
+      (if (symbol? x)
+         (sym-ref symtab x)
+         (make-node 0))
+      x))))
 
-(define (bare-t x)
+(define (bare-type x)
   (and=>
    x
    (lambda (node)
      (let ((x (node-content node)))
        (cond
        ((pair? x)
-        (cons (bare-t (car x)) (bare-t (cdr x))))
+        (cons (bare-type (car x)) (bare-type (cdr x))))
        (else x))))))
 
 (define (pt node)
@@ -299,54 +316,73 @@
   (values))
 
 (define (parse x)
-  (second
-   (let parse% ((tvs '())
-               (x x))
-     (cond
-      ((eq? x '?)
-       (list tvs (make-node #f)))
-      ((zo? x)
-       (list tvs (make-node 0)))
-      ((tv? x)
-       (if-let (z (assoc-ref tvs x))
-              (list tvs (make-node z))
-              (let ((tv (next)))
-                (list (assoc-set! tvs x tv)
-                      (make-node tv)))))
-      ((pair? x)
-       (let* ((a (parse% tvs (car x)))
-             (b (parse% (first a) (cdr x))))
-        (list (first b) (make-node (cons (second a) (second b))))))))))
+  (if (not x)
+      #f
+      (second
+       (let parse% ((tvs '())
+                   (x x))
+        (cond
+         ((eq? x '?)
+          (list tvs (make-node #f)))
+         ((zo? x)
+          (list tvs (make-node 0)))
+         ((tv? x)
+          (if-let (z (assoc-ref tvs x))
+                  (list tvs (make-node z))
+                  (let ((tv (next)))
+                    (list (assoc-set! tvs x tv)
+                          (make-node tv)))))
+         ((pair? x)
+          (let* ((a (parse% tvs (car x)))
+                 (b (parse% (first a) (cdr x))))
+            (list (first b) (make-node (cons (second a) (second b)))))))))))
 
-(define (t symtab expr) (bare-t (t% symtab expr)))
+(define (equal-types? ta tb)
+  (define (equal-types?% ta tb correspondances)
+    (let ((a (node-content ta))
+         (b (node-content tb)))
+      (or
+       (eq? a b)
+       (let ((correspond?
+             (lambda (tx ty correspondances)
+               (let ((x (node-content tx))
+                     (y (node-content ty)))
+                 (cond
+                  ((and (zo? x)
+                        (zo? y))
+                   correspondances)
+                  ((and (tv? x)
+                        (tv? y))
+                   (let ((xy (assoc-ref (car correspondances) x))
+                         (yx (assoc-ref (cdr correspondances) y)))
+                     (if (and (not xy) (not yx))
+                        (cons (assoc-set! (car correspondances) x y)
+                              (assoc-set! (cdr correspondances) y x))
+                        (and (eq? xy y) (eq? yx x) correspondances))))
+                  ((and (pair? x) (pair? y))
+                   (equal-types?% tx ty correspondances))
+                  (else #f))))))
+        (match (list a b)
+          (((a1 . a2) (b1 . b2))
+           (and=>
+            (correspond? a1 b1 correspondances)
+            (lambda (correspondances)
+              (correspond? a2 b2 correspondances))))
+          (else #f))))))
+  (if (or (not ta) (not tb))
+      (eq? ta tb)
+      (and (equal-types?% ta tb '(() . ()))
+          #t)))
 
-(define (curry x)
-  (match x
-    (('quote x) (quote x))
-    (('λc (? symbol? var) body)
-     `(lambda (,var) ,(curry body)))
-    ;; (('letrecc1 ((? symbol? name) expr) body)
-    ;;  `(letrecc1 (,name ,(curry expr)) ,(curry body)))
-    ((f as ...)
-     (fold (lambda (x prev) (list prev (curry x)))
-          (curry f)
-          as))
-    (x x)))
-
-(define (vdc:primitive-eval expr)
-  (t% symtab expr)
-  (primitive-eval (curry expr)))
-
-(define (e symtab expr)
-  (t% symtab expr)
-  (primitive-eval (curry expr)))
-
-(define-syntax vdc:define
+(define-syntax curried-untyped-define
   (syntax-rules ()
     ((_ (name var) body ...)
      (cdefine (name var) body ...))
     ((_ (name var1 var2 ...) body ...)
-     (vdc:define ((name var1) var2 ...) body ...))))
+     (curried-untyped-define ((name var1) var2 ...) body ...))))
+
+(define (∷% name type)
+  (set! symtab (assoc-set! symtab name type)))
 
 (define-syntax-rule (∷ name type)
-  (set! symtab (assoc-set! symtab 'name (parse 'type))))
+  (∷% 'name (parse 'type)))