Improve exception types.

1 files changed, 70 insertions, 34 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index bea3e95..2d7b7f8 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -1041,6 +1041,24 @@
 ;; to type inference the user doesn't have to specify any types expect
 ;; for shader inputs, outputs, and uniforms.
 
+(define &seagull-type-error
+  (make-exception-type '&seagull-type-error &error '()))
+
+(define make-seagull-type-error
+  (record-constructor &seagull-type-error))
+
+(define (seagull-type-error msg args origin)
+  (raise-exception
+   (make-exception
+    (make-seagull-type-error)
+    (make-exception-with-origin origin)
+    (make-exception-with-message
+     (format #f "seagull type error: ~a" msg))
+    (make-exception-with-irritants args))))
+
+(define (type-mismatch a b origin)
+  (seagull-type-error "type mismatch" (list a b) origin))
+
 ;; Primitive types:
 (define (primitive-type name)
   `(primitive ,name))
@@ -1205,7 +1223,10 @@
                 (array-type-length type)))
    ((type-scheme? type)
     type)
-   (else (error "invalid type" type))))
+   (else
+    (seagull-type-error "invalid type"
+                        (list type)
+                        apply-substitution-to-type))))
 
 (define (apply-substitutions-to-type type subs)
   (env-fold (lambda (from to type*)
@@ -1268,22 +1289,9 @@
 (define (single-type texp)
   (match (texp-types texp)
     ((type) type)
-    (_ (error "expected only 1 type" texp))))
-
-(define &seagull-type-error
-  (make-exception-type '&seagull-type-error &error '()))
-
-(define make-seagull-type-error
-  (record-constructor &seagull-type-error))
-
-(define (seagull-type-error msg args origin)
-  (raise-exception
-   (make-exception
-    (make-seagull-type-error)
-    (make-exception-with-origin origin)
-    (make-exception-with-message
-     (format #f "seagull type error: ~a" msg))
-    (make-exception-with-irritants args))))
+    (_ (seagull-type-error "expected single type expression"
+                           (list texp)
+                           single-type))))
 
 (define (occurs? a b)
   (cond
@@ -1601,7 +1609,7 @@
      (apply-substitutions-to-predicate pred subs)))
   ;; TODO: Get information about *why* the predicate failed.
   (unless new-pred
-    (error "predicate failure" pred))
+    (seagull-type-error "type predicate failed" (list pred) eval-predicate*))
   ;; Recursively evaluate the predicate, applying the substitutions
   ;; generated by the last evaluation, until it cannot be simplified
   ;; any further.
@@ -1627,7 +1635,10 @@
     (fold delete
           (free-variables-in-type (type-scheme-ref type))
           (type-scheme-quantifiers type)))
-   (else (error "unknown type" type))))
+   (else
+    (seagull-type-error "unknown type"
+                        (list type)
+                        free-variables-in-type))))
 
 (define (difference a b)
   (match a
@@ -1726,19 +1737,19 @@
 (define (unify:primitives a b)
   (if (equal? a b)
       '()
-      (error "primitive type mismatch" a b)))
+      (type-mismatch a b unify:primitives)))
 
 (define (unify:structs a b)
   (if (equal? a b)
       '()
-      (error "struct type mismatch" a b)))
+      (type-mismatch a b unify:structs)))
 
 (define (unify:variable a b)
   (cond
    ((eq? a b)
     '())
    ((occurs? a b)
-    (error "type contains reference to itself" a b))
+    (seagull-type-error "circular type" (list a b) unify:variable))
    (else
     (list (cons a b)))))
 
@@ -1774,13 +1785,13 @@
     (((? outputs-type?) (? outputs-type?))
      '())
     (((? type?) (? type?))
-     (error "type mismatch" a b))
+     (type-mismatch a b unify))
     ((() ())
      '())
     (((a rest-a ...) (b rest-b ...))
      (unify:lists a rest-a b rest-b))
     (_
-     (error "type mismatch" a b))))
+     (type-mismatch a b unify))))
 
 (define (infer:immediate x)
   (values (texp (list (cond
@@ -2131,6 +2142,8 @@
      (infer:outputs names exps env))
     (('top-level bindings body)
      (infer:top-level bindings body env))
+    ;; User code shouldn't trigger this, only us screwing up an
+    ;; earlier compiler pass.
     (_ (error "unknown form" exp))))
 
 ;; Built-in types:
@@ -2435,8 +2448,7 @@
     (('array-ref array index)
      (find-signatures:array-ref name array index))
     (('outputs (_ exps) ...)
-     (find-signatures:list name exps))
-    (_ (error "uh oh" texp))))
+     (find-signatures:list name exps))))
 
 (define (vars->subs exp env)
   (match exp
@@ -2509,8 +2521,7 @@
                         (extend-env name
                                     (list (type-descriptor->type type))
                                     globals)))))))
-     `(t ,types (top-level ,bindings* ,body)))
-    (_ (error "expected top-level form" program))))
+     `(t ,types (top-level ,bindings* ,body)))))
 
 
 ;;;
@@ -2832,6 +2843,21 @@
 ;; Combine all of the compiler passes on a user provided program and
 ;; emit GLSL code if the program is valid.
 
+(define &seagull-compiler-error
+  (make-exception-type '&seagull-compiler-error &error '()))
+
+(define make-seagull-compiler-error
+  (record-constructor &seagull-compiler-error))
+
+(define (seagull-compiler-error msg args origin)
+  (raise-exception
+   (make-exception
+    (make-seagull-compiler-error)
+    (make-exception-with-origin origin)
+    (make-exception-with-message
+     (format #f "seagull compilation error: ~a" msg))
+    (make-exception-with-irritants args))))
+
 (define-record-type <seagull-global>
   (make-seagull-global qualifier type-descriptor name)
   seagull-global?
@@ -2868,7 +2894,7 @@
 (define* (compile-seagull #:key stage body
                           (inputs '()) (outputs '()) (uniforms '()))
   (unless (memq stage '(vertex fragment))
-    (error "invalid shader stage" stage))
+    (seagull-compiler-error "invalid shader stage" (list stage) compile-seagull))
   (parameterize ((unique-identifier-counter 0)
                  (unique-variable-type-counter 0))
     (let ((source* `(top-level ,(append inputs outputs uniforms)
@@ -3081,7 +3107,9 @@
    ((string>= version "1.2")
     (format port "#version 120\n"))
    (else
-    (error "incompatible GLSL version" version))))
+    (seagull-compiler-error "incompatible GLSL version"
+                            (list version)
+                            emit-version-preprocessor))))
 
 (define (emit-shims version port)
   (when (string<= version "3.3")
@@ -3103,16 +3131,24 @@ vec4 texture(samplerCube tex, vec3 coord) {
 
 (define* (link-seagull-modules vertex fragment version)
   (unless (seagull-module-vertex? vertex)
-    (error "not a vertex shader" vertex))
+    (seagull-compiler-error "not a vertex shader"
+                            (list vertex)
+                            link-seagull-modules))
   (unless (seagull-module-fragment? fragment)
-    (error "not a fragment shader" fragment))
+    (seagull-compiler-error "not a fragment shader"
+                            (list fragment)
+                            link-seagull-modules))
   (parameterize ((unique-identifier-counter
                   (max (seagull-module-max-id vertex)
                        (seagull-module-max-id fragment))))
     (unless (vertex-outputs-match-fragment-inputs? vertex fragment)
-      (error "vertex outputs do not match fragment inputs"))
+      (seagull-compiler-error "vertex outputs do not match fragment inputs"
+                              (list vertex fragment)
+                              link-seagull-modules))
     (unless (uniforms-compatible? vertex fragment)
-      (error "vertex uniforms clash with fragment uniforms"))
+      (seagull-compiler-error "vertex uniforms clash with fragment uniforms"
+                              (list vertex fragment)
+                              link-seagull-modules))
     (define-values (vertex* fragment* uniform-map)
       (link-vertex-outputs-with-fragment-inputs vertex fragment))
     (define vertex-glsl (emit-stage vertex* 'vertex version))