diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 387 |
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)))) ;;; |