From 94ae1ebabe02bf06e1b58184c3d819e1def4be46 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Fri, 13 May 2016 10:15:55 -0400 Subject: [PATCH] refactor variance code into infer-variances function --- tapl/mlish.rkt | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt index e5584eb..3a3a98c 100644 --- a/tapl/mlish.rkt +++ b/tapl/mlish.rkt @@ -293,6 +293,21 @@ (define (contravariant-X? X ty) (variance-contravariant? (find-X-variance X ty))) + ;; infer-variances : Id (Stx-Listof Id) (Stx-Listof Type-Stx) -> (Listof Variance) + (define (infer-variances type-constructor Xs τs) + (define expanded-tys + (for/list ([τ (in-list (stx->list τs))]) + (with-handlers ([exn:fail:syntax? (λ (e) #false)]) + ((current-type-eval) #`(∀ #,Xs #,τ))))) + (for/list ([i (in-range (length (stx->list Xs)))]) + (for/fold ([acc irrelevant]) + ([ty (in-list expanded-tys)]) + (cond [ty + (define/syntax-parse (~?∀ Xs τ) ty) + (define X (list-ref (syntax->list #'Xs) i)) + (variance-join acc (find-X-variance X #'τ))] + [else invariant])))) + ;; compute unbound tyvars in one unexpanded type ty (define (compute-tyvar1 ty) (syntax-parse ty @@ -427,19 +442,8 @@ #'(StructName ...) #'((fld ...) ...)) #:with (Cons? ...) (stx-map mk-? #'(StructName ...)) #:with (exposed-Cons? ...) (stx-map mk-? #'(Cons ...)) - #:do [(define expanded-tys - (for/list ([τ (in-list (syntax->list #'[τ ... ...]))]) - (with-handlers ([exn:fail:syntax? (λ (e) #false)]) - ((current-type-eval) #`(∀ (X ...) #,τ)))))] #:with [arg-variance ...] - (for/list ([i (in-range (length (syntax->list #'[X ...])))]) - (for/fold ([acc irrelevant]) - ([ty (in-list expanded-tys)]) - (cond [ty - (define/syntax-parse (~?∀ Xs τ) ty) - (define X (list-ref (syntax->list #'Xs) i)) - (variance-join acc (find-X-variance X #'τ))] - [else invariant]))) + (infer-variances #'Name #'[X ...] #'[τ ... ...]) #`(begin (define-syntax (NameExtraInfo stx) (syntax-parse stx