From: admin <admin@vouivredigital.com>
Date: Fri, 22 Sep 2023 02:54:54 +0000 (+0900)
Subject: Expand partial applications when needed
X-Git-Tag: v0.1.0~11
X-Git-Url: https://git.vouivredigital.com/?a=commitdiff_plain;h=beb703d63a8644621c7e10ea97f0fd6b6037ae8a;p=vouivre.git

Expand partial applications when needed
---

diff --git a/curry-tests.scm b/curry-tests.scm
index 16ece85..57c7182 100644
--- 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 af7c14d..77489c4 100644
--- 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)))