diff options
Diffstat (limited to 'chickadee/graphics/seagull/types.scm')
| -rw-r--r-- | chickadee/graphics/seagull/types.scm | 337 |
1 files changed, 337 insertions, 0 deletions
diff --git a/chickadee/graphics/seagull/types.scm b/chickadee/graphics/seagull/types.scm new file mode 100644 index 0000000..095d1a8 --- /dev/null +++ b/chickadee/graphics/seagull/types.scm @@ -0,0 +1,337 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; The Seagull static type system. +(define-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (lookup-type + base-type-environment + + type-variable-counter + fresh-type-variable + fresh-type-variables + make-type-variable + type-variable? + type-variable-id + + primitive-type? + primitive-type-name + primitive-type-glsl-name + + <function-type> + make-function-type + function-type? + function-type-parameters + function-type-returns + + type? + type-name + type-glsl-name + type-for-constant + + make-substitutions + substitutions? + unbox-substitutions + no-substitutions + add-substitution + substitute-type + substitute-types + compose-substitutions + occurs? + unify)) + + +;;; +;;; Built-in type registry +;;; + +(define *types* (make-hash-table)) + +(define (lookup-type name) + (hashq-ref *types* name)) + +(define (register-type! name type) + (hashq-set! *types* name type)) + +(define (base-type-environment) + (hash-fold extend (fresh-environment) *types*)) + + +;;; +;;; Type variables +;;; + +(define-record-type <type-variable> + (make-type-variable id) + type-variable? + (id type-variable-id)) + +(set-record-type-printer! <type-variable> + (lambda (tvar port) + (format port "#<type-variable ~a>" + (type-variable-id tvar)))) + +(define type-variable-counter (make-parameter 0)) + +(define (fresh-type-variable) + (let ((id (type-variable-counter))) + (type-variable-counter (+ id 1)) + (make-type-variable id))) + +(define (fresh-type-variables lst) + (map (lambda (_x) (fresh-type-variable)) lst)) + + +;;; +;;; Primitive types +;;; + +(define-record-type <primitive-type> + (make-primitive-type name glsl-name) + primitive-type? + (name primitive-type-name) + (glsl-name primitive-type-glsl-name)) + +(set-record-type-printer! <primitive-type> + (lambda (t port) + (format port "#<primitive-type ~a>" + (primitive-type-name t)))) + +(define-syntax define-primitive-type + (syntax-rules () + ((_ name) + (register-type! 'name (make-primitive-type 'name (symbol->string 'name)))) + ((_ name glsl-name) + (register-type! 'name (make-primitive-type 'name glsl-name))))) + +(define-primitive-type bool) +(define-primitive-type int) +(define-primitive-type float) +(define-primitive-type mat3) +(define-primitive-type mat4) +(define-primitive-type sampler-2d "sampler2D") + + +;;; +;;; Structs +;;; + +(define-record-type <struct-field> + (%make-struct-field name glsl-name type) + struct-field? + (name struct-field-name) + (glsl-name struct-field-glsl-name) + (type struct-field-type)) + +(define* (make-struct-field name type #:key (glsl-name (symbol->string name))) + (%make-struct-field name glsl-name type)) + +(define-record-type <struct> + (make-struct name glsl-name fields) + struct? + (name struct-name) + (glsl-name struct-glsl-name) + (fields struct-fields)) + +(define-syntax define-struct + (syntax-rules () + ((_ (name glsl-name) (field-name field-type field-opt ...) ...) + (register-type! 'name + (make-struct 'name glsl-name + (list + (make-struct-field 'field-name + (lookup-type 'field-type) + field-opt ...) + ...)))) + ((_ name fields ...) + (define-struct (name (symbol->string 'name)) fields ...)))) + +(define-struct vec2 + (x float) + (y float)) + +(define-struct vec3 + (x float) + (y float) + (z float)) + +(define-struct vec4 + (x float) + (y float) + (z float) + (w float)) + + +;;; +;;; Function type +;;; + +(define-record-type <function-type> + (make-function-type parameters returns) + function-type? + (parameters function-type-parameters) + (returns function-type-returns)) + + +;;; +;;; Utils +;;; + +(define (type? obj) + (or (primitive-type? obj))) + +(define (type-name type) + (match type + (($ <primitive-type> _ name) name) + (($ <function-type> params results) + (format #f "(-> ~a ~a)" + (map type-name params) + (map type-name results))) + (($ <type-variable> id) + (format #f "tvar-~a" id)))) + +(define (type-glsl-name type) + (match type + (($ <primitive-type> _ name) name) + ;; TODO: Remove this eventually. + (($ <type-variable> id) + (format #f "t~a" id)))) + +(define (type-for-constant x) + (lookup-type + (cond + ((boolean? x) 'bool) + ((exact-integer? x) 'int) + ((float? x) 'float)))) + + +;;; +;;; Unification +;;; + +(define-record-type <substitutions> + (make-substitutions subs) + substitutions? + (subs unbox-substitutions)) + +(define no-substitutions (make-substitutions '())) + +(define (add-substitution subs a b) + (make-substitutions (alist-cons a b (unbox-substitutions subs)))) + +(define (%substitute-type type from to) + (cond + ((primitive-type? type) + type) + ((type-variable? type) + (if (eq? type from) to type)))) + +(define (substitute-type subs type) + (fold (lambda (pair type*) + (match pair + ((from . to) + (%substitute-type type* from to)))) + type + (unbox-substitutions subs))) + +(define (substitute-types subs types) + (map (lambda (type) + (substitute-type subs type)) + types)) + +(define (compose-substitutions a b) + (define b* + (map (match-lambda + ((from . to) + (cons from (substitute-type a to)))) + (unbox-substitutions b))) + (define a* + (filter-map (match-lambda + ((from . to) + (if (assq-ref b* from) + #f + (cons from to)))) + (unbox-substitutions a))) + (make-substitutions (append a* b*))) + +(define (occurs? a b) + "Return #t if type A appears in type B." + (define (a-occurs? b*) + (occurs? a b*)) + (cond + ((and (type-variable? a) (type-variable? b)) + (eq? a b)) + ((and (type-variable? a) (function-type? b)) + (or (any a-occurs? (function-type-parameters b)) + (any a-occurs? (function-type-returns b)))) + (else #f))) + +(define (type-mismatch a b) + (throw 'type-mismatch a b)) + +(define (unify:primitives a b) + (if (eq? a b) + no-substitutions + (type-mismatch a b))) + +(define (unify:variable a b) + (cond + ((eq? a b) + no-substitutions) + ((occurs? a b) + (type-mismatch a b)) + (else + (add-substitution no-substitutions a b)))) + +(define (unify:functions a b) + (define param-subs + (unify (function-type-parameters a) + (function-type-parameters b))) + (define return-subs + (unify (substitute-types param-subs + (function-type-returns a)) + (substitute-types param-subs + (function-type-returns b)))) + (compose-substitutions param-subs return-subs)) + +(define (unify:pair a b) + (define car-subs (unify (car a) (car b))) + (define cdr-subs (unify (substitute-types car-subs (cdr a)) + (substitute-types car-subs (cdr b)))) + (compose-substitutions car-subs cdr-subs)) + +(define (unify a b) + "Return a list of substitutions that unify types A and B, or throw an +error if A and B are incompatible." + (cond + ((and (primitive-type? a) (primitive-type? b)) + (unify:primitives a b)) + ((type-variable? a) + (unify:variable a b)) + ((type-variable? b) + (unify:variable b a)) + ((and (function-type? a) (function-type? b)) + (unify:functions a b)) + ((and (null? a) (null? b)) + no-substitutions) + ((and (pair? a) (pair? b)) + (unify:pair a b)) + (else + (type-mismatch a b)))) |