Map names to a single type in type environments.

1 files changed, 33 insertions, 47 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index b2058d0..7a22355 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -1710,11 +1710,9 @@
        types))
 
 (define (apply-substitution-to-env env from to)
-  (env-fold (lambda (name types env*)
+  (env-fold (lambda (name type env*)
               (extend-env name
-                          (map (lambda (type)
-                                 (apply-substitution-to-type type from to))
-                               types)
+                          (apply-substitution-to-type type from to)
                           env*))
             (empty-env)
             env))
@@ -1789,12 +1787,6 @@
                 a))
   (append a* b*))
 
-(define (lookup-type name env)
-  (let ((type (lookup name env)))
-    (if (type-scheme? type)
-        (instantiate type)
-        type)))
-
 (define (compose-predicates a b)
   (cond
    ((and (eq? a #t) (eq? b #t))
@@ -2139,15 +2131,10 @@
                                          subs)
        #t)))
 
-(define (maybe-instantiate types)
-  (define types+preds
-    (map (lambda (type)
-           (if (type-scheme? type)
-               (call-with-values (lambda () (instantiate type)) list)
-               (list type #t)))
-         types))
-  (values (map first types+preds)
-          (reduce compose-predicates #t (map second types+preds))))
+(define (maybe-instantiate type)
+  (if (type-scheme? type)
+      (instantiate type)
+      (values type #t)))
 
 (define (unify:primitives a b)
   (if (equal? a b)
@@ -2221,9 +2208,9 @@
           #t))
 
 (define (infer:variable name env)
-  (define-values (types pred)
-    (maybe-instantiate (lookup-type name env)))
-  (values (texp types name)
+  (define-values (type pred)
+    (maybe-instantiate (lookup name env)))
+  (values (texp (list type) name)
           '()
           pred))
 
@@ -2291,7 +2278,7 @@
   ;; The type environment is extended with the function parameters.
   (define env*
     (fold (lambda (param type env*)
-            (extend-env param (list type) env*))
+            (extend-env param type env*))
           env params param-types))
   (define-values (body* body-subs body-pred)
     (infer-exp body env*))
@@ -2309,11 +2296,8 @@
   (define primitive (lookup-seagull-primitive operator))
   ;; Primitive functions may be overloaded and need to be instantiated
   ;; with fresh type variables.
- (define-values (types operator-pred)
-    (maybe-instantiate (list (seagull-primitive-type primitive))))
-  (define operator-type
-    (match types
-      ((type) type)))
+ (define-values (operator-type operator-pred)
+    (maybe-instantiate (seagull-primitive-type primitive)))
   ;; Infer the arguments.
   (define-values (args* arg-subs arg-pred)
     (infer:list args env))
@@ -2422,7 +2406,7 @@
 (define (infer:let names exps body env)
   (define-values (exps* exp-subs exp-pred)
     (infer:list exps env))
-  (define exp-types (map texp-types exps*))
+  (define exp-types (map single-type exps*))
   (define env*
     (fold extend-env
           (apply-substitutions-to-env env exp-subs)
@@ -2455,7 +2439,7 @@
   (define exp-types (map texp-types exps*))
   (define env*
     (fold (lambda (names types env)
-            (fold extend-env env names (map list types)))
+            (fold extend-env env names types))
           (apply-substitutions-to-env env exp-subs)
           names
           exp-types))
@@ -2495,9 +2479,8 @@
 (define (infer:outputs names exps env)
   (define-values (exps* exp-subs exp-pred)
     (infer:list exps env))
-  (define exp-types (map texp-types exps*))
   (define unify-subs
-    (unify (map texp-types exps*)
+    (unify (map single-type exps*)
            (map (lambda (name)
                   (lookup name env))
                 names)))
@@ -2525,7 +2508,7 @@
          (eval-predicate* (compose-predicates pred pred*)
                           (compose-substitutions subs subs*)))
        (define env*
-         (apply-substitutions-to-env (extend-env name (texp-types texp) env)
+         (apply-substitutions-to-env (extend-env name (single-type texp) env)
                                      combined-subs))
        (infer-bindings rest
                        (cons texp texps)
@@ -2533,12 +2516,12 @@
                        new-pred
                        env*))
       (((_ desc name) . rest)
-       (define types (list (type-descriptor->type desc)))
+       (define type (type-descriptor->type desc))
        (infer-bindings rest
-                       (cons types texps)
+                       (cons (list type) texps)
                        subs
                        pred
-                       (extend-env name types env)))))
+                       (extend-env name type env)))))
   (define qualifiers (map first bindings))
   (define names
     (map (match-lambda
@@ -2627,12 +2610,12 @@
 (define (top-level-type-env stage)
   (case stage
     ((vertex)
-     `((vertex:position ,type:vec4)
-       (vertex:point-size ,type:float)
-       (vertex:clip-distance ,type:float)))
+     `((vertex:position . ,type:vec4)
+       (vertex:point-size . ,type:float)
+       (vertex:clip-distance . ,type:float)))
     ((fragment)
-     `((fragment:depth ,type:float)
-       (fragment:coord ,type:vec4)))))
+     `((fragment:depth . ,type:float)
+       (fragment:coord . ,type:vec4)))))
 
 ;; TODO: Add some kind of context object that is threaded through the
 ;; inference process so that when a type error occurs we can show the
@@ -2694,9 +2677,9 @@
 (define (vars->subs exp env)
   (match exp
     (('t ((? variable-type? tvar)) (? symbol? name))
-     (let ((types (lookup* name env)))
-       (if types
-           (list (cons tvar (first types)))
+     (let ((type (lookup* name env)))
+       (if type
+           (list (cons tvar type))
            '())))
     ((head . rest)
      (delete-duplicates
@@ -2737,8 +2720,11 @@
                                (('lambda (params ...) _)
                                 params)))
                            (define env
-                             (compose-envs (fold extend-env (empty-env) params
-                                                 (map list (function-type-parameters type*)))
+                             (compose-envs (fold extend-env
+                                                 (empty-env)
+                                                 params
+                                                 (function-type-parameters
+                                                  type*))
                                            globals))
                            (match func
                              (('lambda _ body)
@@ -2760,7 +2746,7 @@
             (cons (list qualifier type name)
                   (loop rest
                         (extend-env name
-                                    (list (type-descriptor->type type))
+                                    (type-descriptor->type type)
                                     globals)))))))
      `(t ,types (top-level ,bindings* ,body)))))