diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 81 |
1 files changed, 29 insertions, 52 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 2f7cf69..bb7008f 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -859,23 +859,6 @@ (match type (('-> _ returns) returns))) -;; Qualified types: -;; (define (qualified-type type predicate) -;; `(qualified ,type ,predicate)) - -;; (define (qualified-type? type) -;; (match type -;; (('qualified _ _) #t) -;; (_ #f))) - -;; (define (qualified-type-ref type) -;; (match type -;; (('qualified type* _) type*))) - -;; (define (qualified-type-predicate type) -;; (match type -;; (('qualified _ predicate) predicate))) - ;; For all types: (define (for-all-type quantifiers type predicate) `(for-all ,quantifiers ,type ,predicate)) @@ -909,7 +892,6 @@ (or (primitive-type? obj) (type-variable? obj) (function-type? obj) - ;; (qualified-type? obj) (outputs-type? obj))) (define (apply-substitution-to-type type from to) @@ -927,11 +909,6 @@ (map (lambda (return-type) (apply-substitution-to-type return-type from to)) (function-type-returns type)))) - ;; ((qualified-type? type) - ;; (qualified-type (apply-substitution-to-type - ;; (qualified-type-ref type) from to) - ;; (apply-substitution-to-predicate - ;; (qualified-type-predicate type) from to))) ((for-all-type? type) type) (else (error "invalid type" type)))) @@ -977,35 +954,6 @@ exps)) (_ exp))) -(define (apply-substitution-to-predicate pred from to) - (match pred - (#t #t) - (#f #f) - (('= a b) - `(= ,(apply-substitution-to-type a from to) - ,(apply-substitution-to-type b from to))) - (('and preds ...) - `(and ,@(map (lambda (pred) - (apply-substitution-to-predicate pred from to)) - preds))) - (('or preds ...) - `(or ,@(map (lambda (pred) - (apply-substitution-to-predicate pred from to)) - preds))) - (('list preds ...) - `(list ,@(map (lambda (pred) - (apply-substitution-to-predicate pred from to)) - preds))) - (('substitute a b) - `(substitute ,(apply-substitution-to-type a from to) - ,(apply-substitution-to-type b from to))))) - -(define (apply-substitutions-to-predicate pred subs) - (env-fold (lambda (from to pred*) - (apply-substitution-to-predicate pred* from to)) - pred - subs)) - ;; Typed expressions: (define (texp types exp) `(t ,types ,exp)) @@ -1141,6 +1089,35 @@ #t preds)) +(define (apply-substitution-to-predicate pred from to) + (match pred + (#t #t) + (#f #f) + (('= a b) + `(= ,(apply-substitution-to-type a from to) + ,(apply-substitution-to-type b from to))) + (('and preds ...) + `(and ,@(map (lambda (pred) + (apply-substitution-to-predicate pred from to)) + preds))) + (('or preds ...) + `(or ,@(map (lambda (pred) + (apply-substitution-to-predicate pred from to)) + preds))) + (('list preds ...) + `(list ,@(map (lambda (pred) + (apply-substitution-to-predicate pred from to)) + preds))) + (('substitute a b) + `(substitute ,(apply-substitution-to-type a from to) + ,(apply-substitution-to-type b from to))))) + +(define (apply-substitutions-to-predicate pred subs) + (env-fold (lambda (from to pred*) + (apply-substitution-to-predicate pred* from to)) + pred + subs)) + ;; Produces a simplified predicate and a new set of substitutions for ;; predicates that have been satisfied and simplified to #t. It's a ;; bit of a weird process since we're dealing with partial evaluation, |