Use continuation-passing style to get overloads working.

1 files changed, 225 insertions, 162 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 41aacc1..d5b2cc6 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -73,7 +73,7 @@
       (comparison-operator? x)))
 
 (define (primitive-call? x)
- (binary-operator? x))
+  (binary-operator? x))
 
 (define (difference a b)
   (match a
@@ -646,27 +646,29 @@
   (match type
     (('for-all _ t) t)))
 
-;; Intersection types:
-(define (intersection-type . types)
-  `(^ ,types))
+;; Overload types:
+(define (overload-type . types)
+  (match types
+    (((? function-type?) ...)
+     `(overload ,types))))
 
-(define (intersection-type? obj)
+(define (overload-type? obj)
   (match obj
-    (('^ _) #t)
+    (('overload _) #t)
     (_ #f)))
 
-(define (intersection-type-ref type)
+(define (overload-type-ref type)
   (match type
-    (('^ types) types)))
+    (('overload types) types)))
 
 (define (type? obj)
   (or (primitive-type? obj)
       (type-variable? obj)
       (function-type? obj)
-      (intersection-type? obj)))
+      (overload-type? obj)))
 
-(define arithmetic-type
-  (list (intersection-type
+(define add/sub-type
+  (list (overload-type
          (function-type (list int-type int-type)
                         (list int-type))
          (function-type (list float-type float-type)
@@ -685,14 +687,8 @@
 ;; vec4, mat4 -> mat4
 ;; mat4, vec4 -> mat4
 
-(list (intersection-type
-       (function-type (list int-type int-type)
-                      (list int-type))
-       (function-type (list float-type float-type)
-                      (list float-type))))
-
 (define comparison-type
-  (list (intersection-type
+  (list (overload-type
          (function-type (list int-type int-type)
                         (list bool-type))
          (function-type (list float-type float-type)
@@ -712,8 +708,8 @@
 ;;     (>= . ,comparison-type)))
 
 (define (top-level-type-env)
-  `((+ . (,(function-type (list int-type int-type) (list int-type))))
-    (- . (,(function-type (list int-type int-type) (list int-type))))
+  `((+ . ,add/sub-type)
+    (- . ,add/sub-type)
     (* . (,(function-type (list int-type int-type) (list int-type))))
     (/ . (,(function-type (list int-type int-type) (list int-type))))))
 
@@ -742,15 +738,11 @@
      (map (lambda (return-type)
             (apply-substitution-to-type return-type from to))
           (function-type-returns type))))
-   ;; ((intersection-type? type)
-   ;;  (apply intersection-type
-   ;;   (map (lambda (t)
-   ;;          (apply-substitution-to-type t from to))
-   ;;        (intersection-type-ref type))))
-   ;; ((one-of-type? type)
-   ;;  (if (or (one-of-type? to) (condition-type? to))
-   ;;      type
-   ;;      type))
+   ((overload-type? type)
+    (apply overload-type
+           (map (lambda (type)
+                  (apply-substitution-to-type type from to))
+                (overload-type-ref type))))
    (else (error "invalid type" type))))
 
 (define (apply-substitutions-to-type type subs)
@@ -766,25 +758,6 @@
          (apply-substitutions-to-type type subs))
        types))
 
-(define (apply-substitution-to-env from to env)
-  (pk 'sub-env from to env)
-  (env-fold (lambda (name type env*)
-              (extend-env name
-                          (apply-substitution-to-type type from to)
-                          env*))
-            (empty-env)
-            env))
-
-(define (apply-substitutions-to-env subs env)
-  (env-fold (lambda (from to env*)
-              (apply-substitution-to-env from to env*))
-            env
-            subs))
-
-(define (apply-substitutions-to-texp subs exp)
-  (texp (apply-substitutions-to-types (texp-types exp) subs)
-        (texp-exp exp)))
-
 ;; Typed expressions:
 (define (texp types exp)
   `(t ,types ,exp))
@@ -984,144 +957,226 @@
                 a))
   (pk 'compose a b (append a* b*)))
 
-(define (unify:primitives a b)
-  (if (eq? a b)
-      '()
-      (error "type mismatch" a b)))
+(define unify-prompt-tag (make-prompt-tag 'unify))
+
+(define (call-with-unify-rollback thunk handler)
+  (call-with-prompt unify-prompt-tag
+    thunk
+    (lambda (k args)
+      (apply handler args))))
 
-(define (unify:variable a b)
+(define (unify:fail . args)
+  (pk 'unify:fail args)
+  (abort-to-prompt unify-prompt-tag args))
+
+(define (unify:primitives a b success)
+  (pk 'unify:primitives a b)
+  (if (equal? a b)
+      (success '())
+      (unify:fail "type mismatch" a b)))
+
+(define (unify:variable a b success)
+  (pk 'unify:variable a b)
   (cond
    ((eq? a b)
-    '())
+    (success '()))
    ((occurs? a b)
-    (error "type contains reference to itself" a b))
+    (unify:fail "type contains reference to itself" a b))
    (else
-    (list (cons a b)))))
-
-(define (unify:functions a b)
-  (define sub0 (unify (function-type-parameters a)
-                      (function-type-parameters b)))
-  (define sub1 (unify (apply-substitutions-to-types (function-type-returns a)
-                                                    sub0)
-                      (apply-substitutions-to-types (function-type-returns b)
-                                                    sub0)))
-  (compose-substitutions sub0 sub1))
-
-(define (unify:lists a rest-a b rest-b)
-  (compose-substitutions (unify a b)
-                         (unify rest-a rest-b)))
-
-(define (unify . args)
-  (pk 'unify args)
-  (match args
+    (success (list (cons a b))))))
+
+(define (unify:functions a b success)
+  (pk 'unify:functions a b)
+  (unify (function-type-parameters a)
+         (function-type-parameters b)
+         (lambda (sub0)
+           (unify (apply-substitutions-to-types (function-type-returns a)
+                                                sub0)
+                  (apply-substitutions-to-types (function-type-returns b)
+                                                sub0)
+                  (lambda (sub1)
+                    (success (compose-substitutions sub0 sub1)))))))
+
+(define (unify:overload a b success)
+  (pk 'unify:overload a b)
+  (define (try-unify functions)
+    (match functions
+      (()
+       (unify:fail "no matching overload" a b))
+      ((function . rest)
+       (pk 'try-overload function b)
+       (call-with-unify-rollback
+        (lambda ()
+          (unify function b success))
+        (lambda _
+          (try-unify rest))))))
+  (try-unify (overload-type-ref a)))
+
+(define (unify:lists a rest-a b rest-b success)
+  (pk 'unify:lists a rest-a b rest-b)
+  (unify a b
+         (lambda (sub0)
+           (unify (apply-substitutions-to-types rest-a sub0)
+                  (apply-substitutions-to-types rest-b sub0)
+                  (lambda (sub1)
+                    (success (compose-substitutions sub0 sub1)))))))
+
+(define (unify a b success)
+  (pk 'unify a b)
+  (match (list a b)
     (((? primitive-type? a) (? primitive-type? b))
-     (unify:primitives a b))
+     (unify:primitives a b success))
     ((or ((? type-variable? a) b)
          (b (? type-variable? a)))
-     (unify:variable a b))
+     (unify:variable a b success))
     (((? function-type? a) (? function-type? b))
-     (unify:functions a b))
+     (unify:functions a b success))
+    ((a (? overload-type? b))
+     (unify:overload b a success))
     ((() ())
-     '())
+     (success '()))
     (((a rest-a ...) (b rest-b ...))
-     (unify:lists a rest-a b rest-b))
+     (unify:lists a rest-a b rest-b success))
     (_
-     (error "type mismatch" args))))
-
-(define (infer:if types predicate consequent alternate)
-  (pk 'infer:if predicate consequent alternate)
-  (define sub0 (infer predicate))
-  (define sub1 (unify (single-type predicate) bool-type))
-  (define sub2 (compose-substitutions sub0 sub1))
-  (define sub3 (infer consequent))
-  (define sub4 (compose-substitutions sub2 sub3))
-  (define sub5 (infer alternate))
-  (define sub6 (compose-substitutions sub4 sub5))
-  (define sub7 (unify (apply-substitutions-to-types (texp-types consequent) sub6)
-                      (apply-substitutions-to-types (texp-types alternate) sub6)))
-  (compose-substitutions sub6 sub7))
-
-(define (infer:let types names exps body)
-  (define sub0
-    (fold (lambda (exp subs)
-            (compose-substitutions (infer exp) subs))
-          (empty-env)
-          exps))
-  (define sub1 (infer body))
-  (define sub2 (compose-substitutions sub0 sub1))
-  (define sub3 (unify (apply-substitutions-to-types types sub2)
-                      (apply-substitutions-to-types (texp-types body) sub2)))
-  (compose-substitutions sub2 sub3))
-
-(define (infer:lambda type body)
+     (unify:fail "type mismatch" a b))))
+
+(define (infer:list exps subs success)
+  (pk 'infer:list exps)
+  (match exps
+    (() (success '()))
+    ((exp . rest)
+     (infer exp
+            subs
+            (lambda (sub0)
+              (infer:list rest
+                          sub0
+                          (lambda (sub1)
+                            (success
+                             (compose-substitutions sub0 sub1)))))))))
+
+(define (infer:if types predicate consequent alternate subs success)
+  (pk 'infer:if predicate consequent alternate subs)
+  (infer predicate
+         subs
+         (lambda (sub0)
+           (unify (single-type predicate)
+                  bool-type
+                  (lambda (sub1)
+                    (define sub2 (compose-substitutions sub0 sub1))
+                    (infer consequent
+                           sub2
+                           (lambda (sub3)
+                             (infer alternate
+                                    sub3
+                                    (lambda (sub4)
+                                      (unify (apply-substitutions-to-types
+                                              (texp-types consequent)
+                                              sub4)
+                                             (apply-substitutions-to-types
+                                              (texp-types alternate)
+                                              sub4)
+                                             (lambda (sub5)
+                                               (success
+                                                (compose-substitutions
+                                                 sub4 sub5)))))))))))))
+
+(define (infer:lambda type body subs success)
   (pk 'infer:lambda type body)
   (define type*
     (if (for-all-type? type)
         (for-all-type-ref type)
         type))
-  (define sub0 (infer body))
-  (define sub1 (unify (apply-substitutions-to-types (texp-types body) sub0)
-                      (function-type-returns type*)))
-  (compose-substitutions sub0 sub1))
-
-(define (infer:primcall types operator args)
+  (infer body
+         subs
+         (lambda (sub0)
+           (unify (apply-substitutions-to-types (texp-types body) sub0)
+                  (function-type-returns type*)
+                  (lambda (sub1)
+                    (success
+                     (compose-substitutions sub0 sub1)))))))
+
+(define (infer:call types operator args subs success)
+  (pk 'infer:call types operator args subs)
+  (infer operator
+         subs
+         (lambda (sub0)
+           (infer:list
+            args
+            sub0
+            (lambda (sub1)
+              (unify (apply-substitutions-to-type
+                      (function-type (map single-type args)
+                                     types)
+                      sub1)
+                     (apply-substitutions-to-type
+                      (single-type operator)
+                      sub1)
+                     (lambda (sub2)
+                       (success (compose-substitutions sub1 sub2)))))))))
+
+(define (infer:primcall types operator args subs success)
   (pk 'infer:primcall types operator args)
-  (define sub0
-    (fold (lambda (arg subs)
-            (compose-substitutions (infer arg) subs))
-          (empty-env)
-          args))
-  (define sub1
-    (unify (apply-substitutions-to-type (function-type (map single-type args)
-                                                       types)
-                                        sub0)
-           (apply-substitutions-to-type (single-type operator)
-                                        sub0)))
-  (compose-substitutions sub0 sub1))
-
-(define (infer:call types operator args)
-  (pk 'infer:call types operator args)
-  (define sub0 (infer operator))
-  (define sub1
-    (fold (lambda (arg subs)
-            (compose-substitutions (infer arg) subs))
-          sub0
-          args))
-  (define sub2
-    (unify (apply-substitutions-to-type (function-type (map single-type args)
-                                                       types)
-                                        sub1)
-           (apply-substitutions-to-type (single-type operator)
-                                        sub1)))
-  (compose-substitutions sub1 sub2))
-
-(define (infer:top-level types names exps body)
-  (define sub0
-    (fold (lambda (exp subs)
-            (compose-substitutions (infer exp) subs))
-          (infer body)
-          exps))
-  (define sub1
-    (unify (apply-substitutions-to-types types sub0)
-           (apply-substitutions-to-types (texp-types body) sub0)))
-  (compose-substitutions (infer body) sub0))
-
-(define (infer exp)
+  (infer:list
+   args
+   subs
+   (lambda (sub0)
+     (unify (apply-substitutions-to-type
+             (function-type (map single-type args)
+                            types)
+             sub0)
+            (apply-substitutions-to-type
+             (single-type operator)
+             sub0)
+            (lambda (sub1)
+              (success
+               (compose-substitutions sub0 sub1)))))))
+
+(define (infer:let types names exps body subs success)
+  (pk 'infer:let types names exps subs)
+  (infer:list
+   exps
+   subs
+   (lambda (sub0)
+     (infer body
+            sub0
+            (lambda (sub1)
+              (unify (apply-substitutions-to-types types sub1)
+                     (apply-substitutions-to-types (texp-types body) sub1)
+                     (lambda (sub2)
+                       (success
+                        (compose-substitutions sub1 sub2)))))))))
+
+(define (infer:top-level types names exps body subs success)
+  (infer:list
+   exps
+   subs
+   (lambda (sub0)
+     (infer body
+            sub0
+            (lambda (sub1)
+              (unify (apply-substitutions-to-types types sub1)
+                     (apply-substitutions-to-types (texp-types body) sub1)
+                     (lambda (sub2)
+                       (success
+                        (compose-substitutions sub1 sub2)))))))))
+
+(define (infer exp subs success)
   (match exp
     (('t types (or (? immediate?) ('var _ _)))
-     '())
+     (pk 'infer:basic)
+     (success subs))
     (('t types ('if predicate consequent alternate))
-     (infer:if types predicate consequent alternate))
+     (infer:if types predicate consequent alternate subs success))
     (('t types ('let ((names exps) ...) body))
-     (infer:let types names exps body))
+     (infer:let types names exps body subs success))
     (('t (type) ('lambda (params ...) body))
-     (infer:lambda type body))
+     (infer:lambda type body subs success))
     (('t types ('primcall operator args ...))
-     (infer:primcall types operator args))
+     (infer:primcall types operator args subs success))
     (('t types ('call operator args ...))
-     (infer:call types operator args))
+     (infer:call types operator args subs success))
     (('t types ('top-level ((names exps) ...) body))
-     (infer:top-level types names exps body))
+     (infer:top-level types names exps body subs success))
     (_ (error "unknown form" exp))))
 
 (define (resolve:type-variable var env)
@@ -1152,8 +1207,16 @@
     (_ exp)))
 
 (define (infer-types exp)
-  (let ((annotated (pk 'annotated (annotate-exp* exp))))
-    (resolve annotated (infer annotated))))
+  (call-with-unify-rollback
+   (lambda ()
+     (let ((annotated (pk 'annotated (annotate-exp* exp))))
+       (infer annotated
+              '()
+              (lambda (subs)
+                (pk 'result-subs subs)
+                (resolve annotated subs)))))
+   (lambda args
+     (apply error args))))
 
 
 ;;;