Refactor and make <seagull-primitive> type.

1 files changed, 624 insertions, 639 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index a9a5944..408dbc4 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -41,7 +41,7 @@
 ;; - Loops
 ;; - User defined structs
 ;; - Better error messages (especially around type predicate failure)
-;; - Refactor to add define-primitive syntax
+;; - n-ary comparison operators
 ;; - Overloaded functions with multiple arities
 ;; - Helper function modules
 ;; - Shader composition
@@ -106,47 +106,6 @@
       (float? x)
       (boolean? x)))
 
-(define (unary-operator? x)
-  (eq? x 'not))
-
-(define (arithmetic-operator? x)
-  (memq x '(+ - * /)))
-
-(define (comparison-operator? x)
-  (memq x '(= < <= > >=)))
-
-(define (binary-operator? x)
-  (or (arithmetic-operator? x)
-      (comparison-operator? x)))
-
-(define (vector-constructor? x)
-  (memq x '(vec2 vec3 vec4)))
-
-(define (conversion? x)
-  (memq x '(int->float float->int)))
-
-(define (math-function? x)
-  (memq x '(abs sqrt expt min max mod floor ceil sin cos tan
-                clamp mix step smoothstep length)))
-
-(define (vertex-primitive-call? x)
-  #f)
-
-(define (fragment-primitive-call? x)
-  (memq x '(texture)))
-
-(define (primitive-call? x stage)
-  (or (binary-operator? x)
-      (unary-operator? x)
-      (vector-constructor? x)
-      (conversion? x)
-      (math-function? x)
-      (case stage
-        ((vertex)
-         (vertex-primitive-call? x))
-        ((fragment)
-         (fragment-primitive-call? x)))))
-
 (define (top-level-qualifier? x)
   (memq x '(in out uniform)))
 
@@ -239,6 +198,605 @@
 
 
 ;;;
+;;; Types
+;;;
+
+;; Primitive types:
+(define (primitive-type name)
+  `(primitive ,name))
+
+(define (primitive-type? obj)
+  (match obj
+    (('primitive _) #t)
+    (_ #f)))
+
+(define (primitive-type-name type)
+  (match type
+    (('primitive name) name)))
+
+;; Outputs type:
+(define type:outputs '(outputs))
+
+(define (outputs-type? obj)
+  (equal? obj type:outputs))
+
+;; Struct type:
+(define (struct-type name fields)
+  `(struct ,name ,fields))
+
+(define (struct-type? obj)
+  (match obj
+    (('struct _ _) #t)
+    (_ #f)))
+
+(define (struct-type-name type)
+  (match type
+    (('struct name _) name)))
+
+(define (struct-type-fields type)
+  (match type
+    (('struct _ fields) fields)))
+
+(define (struct-type-ref type field)
+  (assq-ref (struct-type-fields type) field))
+
+(define-syntax-rule (define-struct-type (var-name name) (types names) ...)
+  (define var-name (struct-type 'name (list (cons 'names types) ...))))
+
+;; Array type:
+(define (array-type type length)
+  `(array ,type ,length))
+
+(define (array-type? type)
+  (match type
+    (('array _ _) #t)
+    (_ #f)))
+
+(define (array-type-ref type)
+  (match type
+    (('array type _) type)))
+
+(define (array-type-length type)
+  (match type
+    (('array _ n) n)))
+
+;; Type variables:
+(define unique-variable-type-counter (make-parameter 0))
+
+(define (unique-variable-type-number)
+  (let ((n (unique-variable-type-counter)))
+    (unique-variable-type-counter (+ n 1))
+    n))
+
+(define (unique-variable-type-name)
+  (string->symbol
+   (format #f "T~a" (unique-variable-type-number))))
+
+(define (variable-type name)
+  `(tvar ,name))
+
+(define (fresh-variable-type)
+  (variable-type (unique-variable-type-name)))
+
+(define (fresh-variable-types-for-list lst)
+  (map (lambda (_x) (fresh-variable-type)) lst))
+
+(define (variable-type? obj)
+  (match obj
+    (('tvar _) #t)
+    (_ #f)))
+
+;; Function types:
+(define (function-type parameters returns)
+  `(-> ,parameters ,returns))
+
+(define (function-type? obj)
+  (match obj
+    (('-> _ _) #t)
+    (_ #f)))
+
+(define (function-type-parameters type)
+  (match type
+    (('-> params _) params)))
+
+(define (function-type-returns type)
+  (match type
+    (('-> _ returns) returns)))
+
+;; Type schemes:
+(define (type-scheme quantifiers type)
+  `(type-scheme ,quantifiers ,type))
+
+(define (type-scheme? obj)
+  (match obj
+    (('type-scheme _ _) #t)
+    (_ #f)))
+
+(define (type-scheme-quantifiers type)
+  (match type
+    (('type-scheme q _) q)))
+
+(define (type-scheme-ref type)
+  (match type
+    (('type-scheme _ t) t)))
+
+;; Qualified types:
+(define (qualified-type type pred)
+  `(qualified ,type ,pred))
+
+(define (qualified-type? obj)
+  (match obj
+    (('qualified _ _) #t)
+    (_ #f)))
+
+(define (qualified-type-ref type)
+  (match type
+    (('qualified type _) type)))
+
+(define (qualified-type-predicate type)
+  (match type
+    (('qualified _ pred) pred)))
+
+(define (predicate:and . preds)
+  ;; Combine inner 'and' predicates and remove #t predicates.
+  (define preds*
+    (let loop ((preds preds))
+      (match preds
+        (() '())
+        ((('and sub-preds ...) . rest)
+         (append sub-preds (loop rest)))
+        ((#t . rest)
+         (loop rest))
+        ((pred . rest)
+         (cons pred (loop rest))))))
+  (match preds*
+    (() #t)
+    ((pred) pred)
+    (_ `(and ,@preds*))))
+
+(define (predicate:or . preds)
+  (match preds
+    (() #f)
+    ((pred) pred)
+    ((pred ('or sub-preds ...))
+     `(or ,pred ,@sub-preds))
+    (_ `(or ,@preds))))
+
+(define (predicate:any var . types)
+  (apply predicate:or
+         (map (lambda (type)
+                (predicate:= var type))
+              types)))
+
+(define (predicate:list . preds)
+  (define preds*
+    (let loop ((preds preds))
+      (match preds
+        (() '())
+        ((('list sub-preds ...) . rest)
+         (append sub-preds (loop rest)))
+        ((pred . rest)
+         (cons pred (loop rest))))))
+  (match preds*
+    ((pred) pred)
+    (_ `(list ,@preds*))))
+
+(define (predicate:= a b)
+  `(= ,a ,b))
+
+(define (predicate:substitute from to)
+  `(substitute ,from ,to))
+
+(define (predicate:substitutes subs)
+  (apply predicate:and
+         (map (match-lambda
+                ((from . to)
+                 (predicate:substitute from to)))
+              subs)))
+
+(define (predicate:struct-field struct field var)
+  `(struct-field ,struct ,field ,var))
+
+(define (predicate:array-element array var)
+  `(array-element ,array ,var))
+
+(define (type? obj)
+  (or (primitive-type? obj)
+      (variable-type? obj)
+      (function-type? obj)
+      (struct-type? obj)
+      (outputs-type? obj)))
+
+;; Built-in types:
+(define type:int (primitive-type 'int))
+(define type:float (primitive-type 'float))
+(define type:bool (primitive-type 'bool))
+(define-struct-type (type:vec2 vec2)
+  (type:float x)
+  (type:float y))
+(define-struct-type (type:vec3 vec3)
+  (type:float x)
+  (type:float y)
+  (type:float z))
+(define-struct-type (type:vec4 vec4)
+  (type:float x)
+  (type:float y)
+  (type:float z)
+  (type:float w))
+;; TODO: Matrices are technically array types in GLSL, but we are
+;; choosing to represent them opaquely for now to keep things simple.
+(define type:mat3 (primitive-type 'mat3))
+(define type:mat4 (primitive-type 'mat4))
+(define type:sampler-2d (primitive-type 'sampler2D))
+
+
+;;;
+;;; Primitives
+;;;
+
+(define-record-type <seagull-primitive>
+  (%make-seagull-primitive name glsl-name stages type proc expand emit)
+  seagull-primitive?
+  (name seagull-primitive-name)
+  (glsl-name seagull-primitive-glsl-name)
+  (stages seagull-primitive-stages)
+  (type seagull-primitive-type)
+  (proc seagull-primitive-proc)
+  (expand seagull-primitive-expand)
+  (emit seagull-primitive-emit))
+
+(define (make-default-expander name)
+  (define (expand:default args stage env)
+    `(primcall ,name ,@(expand:list args stage env)))
+  expand:default)
+
+(define (make-default-emitter name)
+  (define (emit:default args port)
+    (format port "~a(~a)"
+            name
+            (string-join (map symbol->string args) ", ")))
+  emit:default)
+
+(define (make-infix-emitter name)
+  (define (emit:infix args port)
+    (match args
+      ((a b)
+       (format port "~a ~a ~a" a name b))))
+  emit:infix)
+
+(define* (make-seagull-primitive #:key name type proc
+                                 (glsl-name name)
+                                 (stages '(vertex fragment))
+                                 (expand (make-default-expander name))
+                                 (emit (make-default-emitter glsl-name)))
+  (%make-seagull-primitive name glsl-name stages type proc expand emit))
+
+(define *seagull-primitives* (make-hash-table))
+
+(define (register-seagull-primitive! primitive)
+  (hashq-set! *seagull-primitives*
+              (seagull-primitive-name primitive)
+              primitive)
+  *unspecified*)
+
+(define (lookup-seagull-primitive name)
+  (hashq-ref *seagull-primitives* name))
+
+(define-syntax-rule (define-seagull-primitive name args ...)
+  (register-seagull-primitive!
+   (make-seagull-primitive #:name 'name args ...)))
+
+(define (primitive-call? x stage)
+  (let ((primitive (lookup-seagull-primitive x)))
+    (and (seagull-primitive? primitive)
+         (memq stage (seagull-primitive-stages primitive)))))
+
+(define-syntax overload
+  (syntax-rules (->)
+    ((_ ((var types ...) ...) (-> (args ...) (returns ...)))
+     (parameterize ((unique-variable-type-counter 0))
+       (let ((var (fresh-variable-type)) ...)
+         (type-scheme
+          (list var ...)
+          (qualified-type
+           (function-type (list args ...) (list returns ...))
+           (predicate:list
+            (predicate:any var types ...) ...))))))))
+
+(define-syntax-rule (a+b->c (ta tb tc) ...)
+  (parameterize ((unique-variable-type-counter 0))
+    (let ((a (fresh-variable-type))
+          (b (fresh-variable-type))
+          (c (fresh-variable-type)))
+      (type-scheme
+       (list a b c)
+       (qualified-type
+        (function-type (list a b) (list c))
+        (predicate:or
+         (predicate:and (predicate:= a ta)
+                        (predicate:= b tb)
+                        (predicate:substitute c tc))
+         ...))))))
+
+(define-syntax-rule (a+b+c->d (ta tb tc td) ...)
+  (parameterize ((unique-variable-type-counter 0))
+    (let ((a (fresh-variable-type))
+          (b (fresh-variable-type))
+          (c (fresh-variable-type))
+          (d (fresh-variable-type)))
+      (type-scheme
+       (list a b c d)
+       (qualified-type
+        (function-type (list a b c) (list d))
+        (predicate:or
+         (predicate:and (predicate:= a ta)
+                        (predicate:= b tb)
+                        (predicate:= c tc)
+                        (predicate:substitute d td))
+         ...))))))
+
+(define-seagull-primitive +
+  #:type
+  (overload ((a type:int type:float
+                type:vec2 type:vec3 type:vec4
+                type:mat3 type:mat4))
+            (-> (a a) (a)))
+  #:proc +
+  #:expand
+  (lambda (args stage env)
+    (let loop ((args args))
+      (match args
+        (() 0)
+        ((n) (expand n stage env))
+        ((n . rest)
+         `(primcall + ,(expand n stage env) ,(loop rest))))))
+  #:emit (make-infix-emitter '+))
+
+(define-seagull-primitive -
+  #:type
+  (overload ((a type:int type:float
+                type:vec2 type:vec3 type:vec4
+                type:mat3 type:mat4))
+            (-> (a a) (a)))
+  #:proc -
+  #:expand
+  (lambda (args stage env)
+    (let loop ((args args))
+      (match args
+        ((n) `(primcall - ,(expand n stage env) 0))
+        ((m n)
+         `(primcall - ,(expand m stage env) ,(expand n stage env)))
+        ((n . rest)
+         `(primcall - ,(expand n stage env) ,(loop rest))))))
+  #:emit (make-infix-emitter '-))
+
+(define-seagull-primitive *
+  #:type
+  (a+b->c (type:int type:int type:int)
+          (type:float type:float type:float)
+          (type:int type:float type:float)
+          (type:float type:int type:float)
+          (type:vec2 type:vec2 type:vec2)
+          (type:vec2 type:float type:vec2)
+          (type:float type:vec2 type:vec2)
+          (type:vec3 type:vec3 type:vec3)
+          (type:vec3 type:float type:vec3)
+          (type:float type:vec3 type:vec3)
+          (type:vec4 type:vec4 type:vec4)
+          (type:vec4 type:float type:vec4)
+          (type:float type:vec4 type:vec4)
+          (type:mat3 type:mat3 type:mat3)
+          (type:mat3 type:vec3 type:vec3)
+          (type:vec3 type:mat3 type:vec3)
+          (type:mat4 type:mat4 type:mat4)
+          (type:mat4 type:vec4 type:vec4)
+          (type:vec4 type:mat4 type:vec4))
+  #:proc *
+  #:expand
+  (lambda (args stage env)
+    (let loop ((args args))
+      (match args
+        (() 1)
+        ((n) (expand n stage env))
+        ((n . rest)
+         `(primcall * ,(expand n stage env) ,(loop rest))))))
+  #:emit (make-infix-emitter '*))
+
+(define-seagull-primitive /
+  #:type
+  (a+b->c (type:int type:int type:int)
+          (type:float type:float type:float)
+          (type:float type:int type:float)
+          (type:int type:float type:float)
+          (type:vec2 type:vec2 type:vec2)
+          (type:vec2 type:float type:vec2)
+          (type:vec3 type:vec3 type:vec3)
+          (type:vec3 type:float type:vec3)
+          (type:vec4 type:vec4 type:vec4)
+          (type:vec4 type:float type:vec4)
+          (type:mat3 type:float type:mat3)
+          (type:mat4 type:float type:mat4))
+  ;; The division of two integers can result in a rational,
+  ;; non-integer, such as 1/2.  This isn't how integer division works
+  ;; in GLSL, so we need to round the result to an integer.
+  #:proc
+  (lambda (x y)
+    (let ((result (/ x y)))
+      (if (or (float? result) (integer? result))
+          result
+          (round result))))
+  #:expand
+  (lambda (args stage env)
+    (match args
+      ((n)
+       `(primcall / 1 ,(expand n stage env)))
+      ((m n)
+       `(primcall / ,(expand m stage env) ,(expand n stage env)))
+      ((m n . rest)
+       (let loop ((rest rest)
+                  (exp `(primcall / ,(expand m stage env) ,(expand n stage env))))
+         (match rest
+           ((l)
+            `(primcall / ,exp ,(expand l stage env)))
+           ((l . rest)
+            (loop rest `(primcall / ,exp ,(expand l stage env)))))))))
+  #:emit (make-infix-emitter '/))
+
+(define-seagull-primitive mod
+  #:type
+  (a+b->c (type:float type:float type:float)
+          (type:int type:int type:float)
+          (type:vec2 type:vec2 type:vec2)
+          (type:vec3 type:vec3 type:vec3)
+          (type:vec4 type:vec4 type:vec4)
+          (type:vec2 type:float type:vec2)
+          (type:vec3 type:float type:vec3)
+          (type:vec4 type:float type:vec4))
+  #:proc mod)
+
+(define-seagull-primitive floor
+  #:type
+  (overload ((a type:float type:vec2 type:vec3 type:vec4))
+            (-> (a) (a)))
+  #:proc floor)
+
+(define-seagull-primitive ceiling
+  #:glsl-name 'ceil
+  #:type
+  (overload ((a type:float type:vec2 type:vec3 type:vec4))
+            (-> (a) (a)))
+  #:proc ceiling)
+
+(define-seagull-primitive int->float
+  #:glsl-name 'float
+  #:type (function-type (list type:int) (list type:float))
+  #:proc exact->inexact)
+
+(define-seagull-primitive float->int
+  #:glsl-name 'int
+  #:type (function-type (list type:float) (list type:int))
+  #:proc (compose inexact->exact floor))
+
+(define-syntax define-comparison-primitive
+  (syntax-rules ()
+    ((_ name)
+     (define-comparison-primitive name name))
+    ((_ name glsl-name)
+     (define-seagull-primitive name
+       #:glsl-name 'glsl-name
+       #:type
+       (overload ((a type:int type:float))
+                 (-> (a a) (type:bool)))
+       #:proc name
+       #:emit (make-infix-emitter 'glsl-name)))))
+
+(define-comparison-primitive = ==)
+(define-comparison-primitive <)
+(define-comparison-primitive <=)
+(define-comparison-primitive >)
+(define-comparison-primitive >=)
+
+(define-seagull-primitive not
+  #:glsl-name '!
+  #:type (function-type (list type:bool) (list type:bool))
+  #:emit
+  (lambda (args port)
+    (match args
+      ((a)
+       (format port "!(~a)" a)))))
+
+(define-seagull-primitive vec2
+  #:type
+  (function-type (list type:float type:float)
+                 (list type:vec2)))
+
+(define-seagull-primitive vec3
+  #:type
+  (function-type (list type:float type:float type:float)
+                 (list type:vec3)))
+
+(define-seagull-primitive vec4
+  #:type
+  (function-type (list type:float type:float type:float type:float)
+                 (list type:vec4)))
+
+(define-seagull-primitive length
+  #:type
+  (overload ((a type:float type:vec2 type:vec3 type:vec4))
+            (-> (a) (type:float))))
+
+(define-seagull-primitive abs
+  #:type
+  (overload ((a type:int type:float))
+            (-> (a) (a)))
+  #:proc abs)
+
+(define-seagull-primitive sqrt
+  #:type (function-type (list type:float) (list type:float))
+  #:proc sqrt)
+
+(define-seagull-primitive expt
+  #:glsl-name 'pow
+  #:type
+  (overload ((a type:float type:vec2 type:vec3 type:vec4))
+            (-> (a a) (a)))
+  #:proc expt)
+
+(define-seagull-primitive min
+  #:type (overload ((a type:int type:float)) (-> (a a) (a)))
+  #:proc min)
+
+(define-seagull-primitive max
+  #:type (overload ((a type:int type:float)) (-> (a a) (a)))
+  #:proc min)
+
+(define-seagull-primitive sin
+  #:type (function-type (list type:float) (list type:float))
+  #:proc sin)
+
+(define-seagull-primitive cos
+  #:type (function-type (list type:float) (list type:float))
+  #:proc cos)
+
+(define-seagull-primitive tan
+  #:type (function-type (list type:float) (list type:float))
+  #:proc tan)
+
+(define-seagull-primitive clamp
+  #:type (overload ((a type:int type:float)) (-> (a a a) (a))))
+
+(define-seagull-primitive mix
+  #:type
+  (overload ((a type:int type:float type:vec2 type:vec3 type:vec4))
+            (-> (a a type:float) (a))))
+
+(define-seagull-primitive step
+  #:type
+  (a+b->c (type:float type:float type:float)
+          (type:vec2 type:vec2 type:vec2)
+          (type:vec3 type:vec3 type:vec3)
+          (type:vec4 type:vec4 type:vec4)
+          (type:float type:vec2 type:vec2)
+          (type:float type:vec3 type:vec3)
+          (type:float type:vec4 type:vec4)))
+
+(define-seagull-primitive smoothstep
+  #:type
+  (a+b+c->d (type:float type:float type:float type:float)
+            (type:vec2 type:vec2 type:vec2 type:vec2)
+            (type:vec3 type:vec3 type:vec3 type:vec3)
+            (type:vec4 type:vec4 type:vec4 type:vec4)
+            (type:float type:float type:vec2 type:vec2)
+            (type:float type:float type:vec3 type:vec3)
+            (type:float type:float type:vec4 type:vec4)))
+
+(define-seagull-primitive texture
+  #:stages '(fragment)
+  #:type (function-type (list type:sampler-2d type:vec2)
+                        (list type:vec4)))
+
+
+;;;
 ;;; Macro expansion and alpha conversion
 ;;;
 
@@ -398,47 +956,6 @@
     (_
      (seagull-syntax-error "invalid begin form" `(begin ,@body) expand:begin))))
 
-;; Arithmetic operators, in true Lisp fashion, can accept many
-;; arguments.  + and * accept 0 or more. - and / accept one or more.
-;; The expansion pass transforms all such expressions into binary
-;; operator form.
-(define (expand:+ args stage env)
-  (match args
-    (() 0)
-    ((n) (expand n stage env))
-    ((n . rest)
-     `(primcall + ,(expand n stage env) ,(expand:+ rest stage env)))))
-
-(define (expand:- args stage env)
-  (match args
-    ((n) `(primcall - ,(expand n stage env) 0))
-    ((m n)
-     `(primcall - ,(expand m stage env) ,(expand n stage env)))
-    ((n . rest)
-     `(primcall - ,(expand n stage env) ,(expand:- rest stage env)))))
-
-(define (expand:* args stage env)
-  (match args
-    (() 1)
-    ((n) (expand n stage env))
-    ((n . rest)
-     `(primcall * ,(expand n stage env) ,(expand:* rest stage env)))))
-
-(define (expand:/ args stage env)
-  (match args
-    ((n)
-     `(primcall / 1 ,(expand n stage env)))
-    ((m n)
-     `(primcall / ,(expand m stage env) ,(expand n stage env)))
-    ((m n . rest)
-     (let loop ((rest rest)
-                (exp `(primcall / ,(expand m stage env) ,(expand n stage env))))
-       (match rest
-         ((l)
-          `(primcall / ,exp ,(expand l stage env)))
-         ((l . rest)
-          (loop rest `(primcall / ,exp ,(expand l stage env)))))))))
-
 (define (expand:or exps stage env)
   (match exps
     (() #f)
@@ -497,7 +1014,8 @@
   (expand `(let ((key ,key)) ,(case->if clauses)) stage env))
 
 (define (expand:primitive-call operator operands stage env)
-  `(primcall ,operator ,@(expand:list operands stage env)))
+  (let ((primitive (lookup-seagull-primitive operator)))
+    ((seagull-primitive-expand primitive) operands stage env)))
 
 (define (expand:call operator operands stage env)
   `(call ,(expand operator stage env) ,@(expand:list operands stage env)))
@@ -562,14 +1080,6 @@
      (expand:let* bindings body stage env))
     (('let*-values (bindings ...) body)
      (expand:let*-values bindings body stage env))
-    (('+ args ...)
-     (expand:+ args stage env))
-    (('- args ...)
-     (expand:- args stage env))
-    (('* args ...)
-     (expand:* args stage env))
-    (('/ args ...)
-     (expand:/ args stage env))
     (('or exps ...)
      (expand:or exps stage env))
     (('and exps ...)
@@ -679,37 +1189,10 @@
       `(let-values ,bindings
          ,(simplify-exp body env*))))
 
-;; The division of two integers can result in a rational, non-integer,
-;; such as 1/2.  This isn't how integer division works in GLSL, so we
-;; need to round the result to an integer.
-(define (glsl-divide x y)
-  (let ((result (/ x y)))
-    (if (or (float? result) (integer? result))
-        result
-        (round result))))
-
-(define %simplify-primitives
-  `((+ . ,+)
-    (- . ,-)
-    (* . ,*)
-    (/ . ,glsl-divide)
-    (= . ,=)
-    (< . ,<)
-    (<= . ,<=)
-    (> . ,>)
-    (>= . ,>=)
-    (mod . ,mod)
-    (sqrt . ,sqrt)
-    (expt . ,expt)
-    (min . ,min)
-    (max . ,max)
-    (sin . ,sin)
-    (cos . ,cos)
-    (tan . ,tan)))
-
 (define (simplify:primcall op args env)
-  (let ((proc (assq-ref %simplify-primitives op))
-        (args* (simplify:list args env)))
+  (let* ((primitive (lookup-seagull-primitive op))
+         (proc (seagull-primitive-proc primitive))
+         (args* (simplify:list args env)))
     (if (and (procedure? proc) (every constant? args*))
         (apply proc args*)
         `(primcall ,op ,@args*))))
@@ -1206,149 +1689,6 @@
 (define (type-mismatch a b origin)
   (seagull-type-error "type mismatch" (list a b) origin))
 
-;; Primitive types:
-(define (primitive-type name)
-  `(primitive ,name))
-
-(define (primitive-type? obj)
-  (match obj
-    (('primitive _) #t)
-    (_ #f)))
-
-(define (primitive-type-name type)
-  (match type
-    (('primitive name) name)))
-
-;; Outputs type:
-(define type:outputs '(outputs))
-
-(define (outputs-type? obj)
-  (equal? obj type:outputs))
-
-;; Struct type:
-(define (struct-type name fields)
-  `(struct ,name ,fields))
-
-(define (struct-type? obj)
-  (match obj
-    (('struct _ _) #t)
-    (_ #f)))
-
-(define (struct-type-name type)
-  (match type
-    (('struct name _) name)))
-
-(define (struct-type-fields type)
-  (match type
-    (('struct _ fields) fields)))
-
-(define (struct-type-ref type field)
-  (assq-ref (struct-type-fields type) field))
-
-(define-syntax-rule (define-struct-type (var-name name) (types names) ...)
-  (define var-name (struct-type 'name (list (cons 'names types) ...))))
-
-;; Array type:
-(define (array-type type length)
-  `(array ,type ,length))
-
-(define (array-type? type)
-  (match type
-    (('array _ _) #t)
-    (_ #f)))
-
-(define (array-type-ref type)
-  (match type
-    (('array type _) type)))
-
-(define (array-type-length type)
-  (match type
-    (('array _ n) n)))
-
-;; Type variables:
-(define unique-variable-type-counter (make-parameter 0))
-
-(define (unique-variable-type-number)
-  (let ((n (unique-variable-type-counter)))
-    (unique-variable-type-counter (+ n 1))
-    n))
-
-(define (unique-variable-type-name)
-  (string->symbol
-   (format #f "T~a" (unique-variable-type-number))))
-
-(define (variable-type name)
-  `(tvar ,name))
-
-(define (fresh-variable-type)
-  (variable-type (unique-variable-type-name)))
-
-(define (fresh-variable-types-for-list lst)
-  (map (lambda (_x) (fresh-variable-type)) lst))
-
-(define (variable-type? obj)
-  (match obj
-    (('tvar _) #t)
-    (_ #f)))
-
-;; Function types:
-(define (function-type parameters returns)
-  `(-> ,parameters ,returns))
-
-(define (function-type? obj)
-  (match obj
-    (('-> _ _) #t)
-    (_ #f)))
-
-(define (function-type-parameters type)
-  (match type
-    (('-> params _) params)))
-
-(define (function-type-returns type)
-  (match type
-    (('-> _ returns) returns)))
-
-;; Type schemes:
-(define (type-scheme quantifiers type)
-  `(type-scheme ,quantifiers ,type))
-
-(define (type-scheme? obj)
-  (match obj
-    (('type-scheme _ _) #t)
-    (_ #f)))
-
-(define (type-scheme-quantifiers type)
-  (match type
-    (('type-scheme q _) q)))
-
-(define (type-scheme-ref type)
-  (match type
-    (('type-scheme _ t) t)))
-
-;; Qualified types:
-(define (qualified-type type pred)
-  `(qualified ,type ,pred))
-
-(define (qualified-type? obj)
-  (match obj
-    (('qualified _ _) #t)
-    (_ #f)))
-
-(define (qualified-type-ref type)
-  (match type
-    (('qualified type _) type)))
-
-(define (qualified-type-predicate type)
-  (match type
-    (('qualified _ pred) pred)))
-
-(define (type? obj)
-  (or (primitive-type? obj)
-      (variable-type? obj)
-      (function-type? obj)
-      (struct-type? obj)
-      (outputs-type? obj)))
-
 (define (apply-substitution-to-type type from to)
   (cond
    ((or (primitive-type? type)
@@ -1472,61 +1812,6 @@
         (instantiate type)
         type)))
 
-(define (predicate:and . preds)
-  ;; Combine inner 'and' predicates and remove #t predicates.
-  (define preds*
-    (let loop ((preds preds))
-      (match preds
-        (() '())
-        ((('and sub-preds ...) . rest)
-         (append sub-preds (loop rest)))
-        ((#t . rest)
-         (loop rest))
-        ((pred . rest)
-         (cons pred (loop rest))))))
-  (match preds*
-    (() #t)
-    ((pred) pred)
-    (_ `(and ,@preds*))))
-
-(define (predicate:or . preds)
-  (match preds
-    (() #f)
-    ((pred) pred)
-    ((pred ('or sub-preds ...))
-     `(or ,pred ,@sub-preds))
-    (_ `(or ,@preds))))
-
-(define (predicate:list . preds)
-  (define preds*
-    (let loop ((preds preds))
-      (match preds
-        (() '())
-        ((('list sub-preds ...) . rest)
-         (append sub-preds (loop rest)))
-        ((pred . rest)
-         (cons pred (loop rest))))))
-  `(list ,@preds*))
-
-(define (predicate:= a b)
-  `(= ,a ,b))
-
-(define (predicate:substitute from to)
-  `(substitute ,from ,to))
-
-(define (predicate:substitutes subs)
-  (apply predicate:and
-         (map (match-lambda
-                ((from . to)
-                 (predicate:substitute from to)))
-              subs)))
-
-(define (predicate:struct-field struct field var)
-  `(struct-field ,struct ,field ,var))
-
-(define (predicate:array-element array var)
-  `(array-element ,array ,var))
-
 (define (compose-predicates a b)
   (cond
    ((and (eq? a #t) (eq? b #t))
@@ -2038,11 +2323,11 @@
           subs #t))
 
 (define (infer:primitive-call operator args env)
-  ;; The type signature of primitive functions can be looked up
-  ;; directly in the environment.  Primitive functions may be
-  ;; overloaded and need to be instantiated with fresh type variables.
-  (define-values (types operator-pred)
-    (maybe-instantiate (lookup-type operator env)))
+  (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)))
@@ -2337,28 +2622,6 @@
     ;; earlier compiler pass.
     (_ (error "unknown form" exp))))
 
-;; Built-in types:
-(define type:int (primitive-type 'int))
-(define type:float (primitive-type 'float))
-(define type:bool (primitive-type 'bool))
-(define-struct-type (type:vec2 vec2)
-  (type:float x)
-  (type:float y))
-(define-struct-type (type:vec3 vec3)
-  (type:float x)
-  (type:float y)
-  (type:float z))
-(define-struct-type (type:vec4 vec4)
-  (type:float x)
-  (type:float y)
-  (type:float z)
-  (type:float w))
-;; TODO: Matrices are technically array types in GLSL, but we are
-;; choosing to represent them opaquely for now to keep things simple.
-(define type:mat3 (primitive-type 'mat3))
-(define type:mat4 (primitive-type 'mat4))
-(define type:sampler-2d (primitive-type 'sampler2D))
-
 (define (type-descriptor->type desc)
   (match desc
     ('bool type:bool)
@@ -2378,258 +2641,15 @@
          ((length . rest)
           (loop rest (array-type prev length))))))))
 
-(define-syntax-rule (a+b->c (ta tb tc) ...)
-  (let ((a (fresh-variable-type))
-        (b (fresh-variable-type))
-        (c (fresh-variable-type)))
-    (list (type-scheme
-           (list a b c)
-           (qualified-type
-            (function-type (list a b) (list c))
-            (predicate:or
-             (predicate:and (predicate:= a ta)
-                            (predicate:= b tb)
-                            (predicate:substitute c tc))
-             ...))))))
-
-(define-syntax-rule (a+b+c->d (ta tb tc td) ...)
-  (let ((a (fresh-variable-type))
-        (b (fresh-variable-type))
-        (c (fresh-variable-type))
-        (d (fresh-variable-type)))
-    (list (type-scheme
-           (list a b c d)
-           (qualified-type
-            (function-type (list a b c) (list d))
-            (predicate:or
-             (predicate:and (predicate:= a ta)
-                            (predicate:= b tb)
-                            (predicate:= c tc)
-                            (predicate:substitute d td))
-             ...))))))
-
 (define (top-level-type-env stage)
-  (define type:+/-
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a a) (list a))
-              (predicate:or
-               (predicate:= a type:int)
-               (predicate:= a type:float)
-               (predicate:= a type:vec2)
-               (predicate:= a type:vec3)
-               (predicate:= a type:vec4)
-               (predicate:= a type:mat3)
-               (predicate:= a type:mat4)))))))
-  (define type:*
-    (a+b->c (type:int type:int type:int)
-            (type:float type:float type:float)
-            (type:int type:float type:float)
-            (type:float type:int type:float)
-            (type:vec2 type:vec2 type:vec2)
-            (type:vec2 type:float type:vec2)
-            (type:float type:vec2 type:vec2)
-            (type:vec3 type:vec3 type:vec3)
-            (type:vec3 type:float type:vec3)
-            (type:float type:vec3 type:vec3)
-            (type:vec4 type:vec4 type:vec4)
-            (type:vec4 type:float type:vec4)
-            (type:float type:vec4 type:vec4)
-            (type:mat3 type:mat3 type:mat3)
-            (type:mat3 type:vec3 type:vec3)
-            (type:vec3 type:mat3 type:vec3)
-            (type:mat4 type:mat4 type:mat4)
-            (type:mat4 type:vec4 type:vec4)
-            (type:vec4 type:mat4 type:vec4)))
-  (define type:/
-    (a+b->c (type:int type:int type:int)
-            (type:float type:float type:float)
-            (type:float type:int type:float)
-            (type:int type:float type:float)
-            (type:vec2 type:vec2 type:vec2)
-            (type:vec2 type:float type:vec2)
-            (type:vec3 type:vec3 type:vec3)
-            (type:vec3 type:float type:vec3)
-            (type:vec4 type:vec4 type:vec4)
-            (type:vec4 type:float type:vec4)
-            (type:mat3 type:float type:mat3)
-            (type:mat4 type:float type:mat4)))
-  (define type:mod
-    (a+b->c (type:float type:float type:float)
-            (type:int type:int type:float)
-            (type:vec2 type:vec2 type:vec2)
-            (type:vec3 type:vec3 type:vec3)
-            (type:vec4 type:vec4 type:vec4)
-            (type:vec2 type:float type:vec2)
-            (type:vec3 type:float type:vec3)
-            (type:vec4 type:float type:vec4)))
-  (define type:floor/ceil
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a) (list a))
-              (predicate:or
-               (predicate:= a type:float)
-               (predicate:= a type:vec2)
-               (predicate:= a type:vec3)
-               (predicate:= a type:vec4)))))))
-  (define type:int->float
-    (list (function-type (list type:int) (list type:float))))
-  (define type:float->int
-    (list (function-type (list type:float) (list type:int))))
-  (define type:comparison
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a a) (list type:bool))
-              (predicate:or
-               (predicate:= a type:int)
-               (predicate:= a type:float)))))))
-  (define type:not
-    (list (function-type (list type:bool) (list type:bool))))
-  (define type:make-vec2
-    (list (function-type (list type:float type:float)
-                         (list type:vec2))))
-  (define type:make-vec3
-    (list (function-type (list type:float type:float type:float)
-                         (list type:vec3))))
-  (define type:make-vec4
-    (list (function-type (list type:float type:float type:float type:float)
-                         (list type:vec4))))
-  (define type:length
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a) (list type:float))
-              (predicate:or
-               (predicate:= a type:float)
-               (predicate:= a type:vec2)
-               (predicate:= a type:vec3)
-               (predicate:= a type:vec4)))))))
-  (define type:abs
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a) (list a))
-              (predicate:or
-               (predicate:= a type:int)
-               (predicate:= a type:float)))))))
-  (define type:sqrt
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a) (list a))
-              (predicate:or
-               (predicate:= a type:int)
-               (predicate:= a type:float)))))))
-  (define type:expt
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a a) (list a))
-              (predicate:or
-               (predicate:= a type:float)
-               (predicate:= a type:vec2)
-               (predicate:= a type:vec3)
-               (predicate:= a type:vec4)))))))
-  (define type:min/max
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a a) (list a))
-              (predicate:or
-               (predicate:= a type:int)
-               (predicate:= a type:float)))))))
-  (define type:trig
-    (list (function-type (list type:float) (list type:float))))
-  (define type:clamp
-    (let ((a (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a a a) (list a))
-              (predicate:or
-               (predicate:= a type:int)
-               (predicate:= a type:float)))))))
-  (define type:mix
-    (let ((a (fresh-variable-type))
-          (b (fresh-variable-type)))
-      (list (type-scheme
-             (list a)
-             (qualified-type
-              (function-type (list a a type:float) (list a))
-              (predicate:or
-               (predicate:= a type:int)
-               (predicate:= a type:float)
-               (predicate:= a type:vec4)))))))
-  (define type:step
-    (a+b->c (type:float type:float type:float)
-            (type:vec2 type:vec2 type:vec2)
-            (type:vec3 type:vec3 type:vec3)
-            (type:vec4 type:vec4 type:vec4)
-            (type:float type:vec2 type:vec2)
-            (type:float type:vec3 type:vec3)
-            (type:float type:vec4 type:vec4)))
-  (define type:smoothstep
-    (a+b+c->d (type:float type:float type:float type:float)
-              (type:vec2 type:vec2 type:vec2 type:vec2)
-              (type:vec3 type:vec3 type:vec3 type:vec3)
-              (type:vec4 type:vec4 type:vec4 type:vec4)
-              (type:float type:float type:vec2 type:vec2)
-              (type:float type:float type:vec3 type:vec3)
-              (type:float type:float type:vec4 type:vec4)))
-  (define type:texture
-    (list (function-type (list type:sampler-2d type:vec2)
-                         (list type:vec4))))
-  `((+ . ,type:+/-)
-    (- . ,type:+/-)
-    (* . ,type:*)
-    (/ . ,type:/)
-    (mod . ,type:mod)
-    (floor . ,type:floor/ceil)
-    (ceil . ,type:floor/ceil)
-    (int->float . ,type:int->float)
-    (float->int . ,type:float->int)
-    (= . ,type:comparison)
-    (< . ,type:comparison)
-    (<= . ,type:comparison)
-    (> . ,type:comparison)
-    (>= . ,type:comparison)
-    (not . ,type:not)
-    (vec2 . ,type:make-vec2)
-    (vec3 . ,type:make-vec3)
-    (vec4 . ,type:make-vec4)
-    (length . ,type:length)
-    (abs . ,type:abs)
-    (sqrt . ,type:sqrt)
-    (expt . ,type:expt)
-    (min . ,type:min/max)
-    (max . ,type:min/max)
-    (step . ,type:step)
-    (smoothstep . ,type:smoothstep)
-    (sin . ,type:trig)
-    (cos . ,type:trig)
-    (tan . ,type:trig)
-    (clamp . ,type:clamp)
-    (mix . ,type:mix)
-    ,@(case stage
-        ((vertex)
-         `((vertex:position ,type:vec4)
-           (vertex:point-size ,type:float)
-           (vertex:clip-distance ,type:float)))
-        ((fragment)
-         `((fragment:depth ,type:float)
-           (fragment:coord ,type:vec4)
-           (texture . ,type:texture))))))
+  (case stage
+    ((vertex)
+     `((vertex:position ,type:vec4)
+       (vertex:point-size ,type:float)
+       (vertex:clip-distance ,type:float)))
+    ((fragment)
+     `((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
@@ -2821,31 +2841,6 @@
   (format port "bool ~a = ~a;\n" temp (if b "true" "false"))
   (list temp))
 
-(define (emit:binary-operator type op a b stage version port level)
-  (define op*
-    (case op
-      ((=) '==)
-      (else op)))
-  (define a-temp (single-temp (emit-glsl a stage version port level)))
-  (define b-temp (single-temp (emit-glsl b stage version port level)))
-  (define temp (unique-identifier))
-  (indent level port)
-  (format port "~a ~a = ~a ~a ~a;\n"
-          (type->glsl type) temp a-temp op* b-temp)
-  (list temp))
-
-(define (emit:unary-operator type op a stage version port level)
-  (define op*
-    (case op
-      ((not) '!)
-      (else op)))
-  (define a-temp (single-temp (emit-glsl a stage version port level)))
-  (define temp (unique-identifier))
-  (indent level port)
-  (format port "~a ~a = ~a(~a);\n"
-          (type->glsl type) temp op* a-temp)
-  (list temp))
-
 (define (emit:declaration type lhs rhs port level)
   (unless (outputs-type? type)
     (indent level port)
@@ -2949,26 +2944,20 @@
   (emit:declarations (texp-types body) let-temps body-temps port level)
   let-temps)
 
-(define %primcall-map
-  '((float->int . int)
-    (int->float . float)
-    (expt . pow)
-    (texture . texture)))
-
 (define (emit:primcall type operator args stage version port level)
-  (define operator*
-    (or (assq-ref %primcall-map operator) operator))
+  (define primitive (lookup-seagull-primitive operator))
+  (define operator* (seagull-primitive-glsl-name primitive))
   (define arg-temps
     (map (lambda (arg)
            (single-temp (emit-glsl arg stage version port level)))
          args))
   (define output-temp (unique-identifier))
   (indent level port)
-  (format port "~a ~a = ~a(~a);\n"
+  (format port "~a ~a = "
           (type->glsl type)
-          output-temp
-          operator*
-          (string-join (map symbol->string arg-temps) ", "))
+          output-temp)
+  ((seagull-primitive-emit primitive) arg-temps port)
+  (format port ";\n")
   (list output-temp))
 
 (define (emit:call types operator args stage version port level)
@@ -3075,10 +3064,6 @@
      (emit:let types names exps body stage version port level))
     (('t types ('let-values ((names exps) ...) body))
      (emit:let-values types names exps body stage version port level))
-    (('t (type) ('primcall (? binary-operator? op) a b))
-     (emit:binary-operator type op a b stage version port level))
-    (('t (type) ('primcall (? unary-operator? op) a))
-     (emit:unary-operator type op a stage version port level))
     (('t (type) ('primcall op args ...))
      (emit:primcall type op args stage version port level))
     (('t types ('call operator args ...))