This commit is contained in:
Georges Dupéron 2017-09-26 18:54:29 +02:00
parent bdbf4561dc
commit d709704cd7
2 changed files with 6 additions and 18 deletions
macrotypes
turnstile/examples

View File

@ -85,7 +85,6 @@
;; a base type. We also know #'b is not a var, so #'b has
;; to be the same "identifier base type" as #'a.
(unless (and (identifier? #'b) (free-identifier=? #'a #'b))
(displayln 1)
(type-error #:src (get-orig #'b)
#:msg (format "couldn't unify ~~a and ~~a\n expected: ~a\n given: ~a"
(string-join (map type->str (stx-map stx-car orig-cs)) ", ")
@ -114,7 +113,6 @@
#'((τ1 τ2) ... . rst)
orig-cs)]
[else
(displayln 2)
(type-error #:src (get-orig #'b)
#:msg (format "couldn't unify ~~a and ~~a\n expected: ~a\n given: ~a"
(string-join (map type->str (stx-map stx-car orig-cs)) ", ")
@ -155,7 +153,7 @@
[old-solution (make-immutable-free-id-table)])
(define Xset (immutable-free-id-set (stx->list Xs)))
(define X? (curry free-id-set-member? Xset))
(add-constraints/variance/var? Xs X? X→variance ab+variance* old-solution orig-cs))
(add-constraints/variance/var? X? X→variance ab+variance* old-solution orig-cs))
;; (-> Any Boolean : (∩ X Id))
;; (ImmutableFreeIdTable (∩ X Id) Variance)
@ -164,17 +162,14 @@
;; (Stx-Listof (Stx-List Stx Stx))
;; ->
;; (ImmutableFreeIdTable (∩ X Id) Type)
(define (add-constraints/variance/var? Xs X? X→variance ab+variance* old-solution orig-cs)
(newline)
(display 'ab+variance*)(displayln ab+variance*)
(define (add-constraints/variance/var? X? X→variance ab+variance* old-solution orig-cs)
(define-syntax-class X
(pattern v:id
#:when (X? #'v)
#:attr variance (or (free-id-table-ref X→variance #'a #f)
invariant)))
(define (do-error eee)
(define (do-error)
(define/with-syntax [(a b _) . _] ab+variance*)
(displayln eee)
(type-error #:src (get-orig #'b)
#:msg (format "couldn't unify ~~a and ~~a\n expected: ~a\n given: ~a"
(string-join (map type->str (stx-map stx-car orig-cs)) ", ")
@ -185,7 +180,7 @@
datum=?)
#'a))
(define (continue new-ab* new-solution)
(add-constraints/variance/var? Xs X? X→variance new-ab* new-solution orig-cs))
(add-constraints/variance/var? X? X→variance new-ab* new-solution orig-cs))
(syntax-parse ab+variance*
[() old-solution]
[((caller-τ callee-τ:X a/b-variance) . rest)
@ -195,7 +190,7 @@
(define v (variance-join (attribute callee-τ.variance)
(syntax->datum #'a/b-variance)))
(unless (typecheck?/variance v existing #'caller-τ)
(do-error 33))))
(do-error))))
(continue #'rest
(free-id-table-set old-solution #'callee-τ #'caller-τ))]
#;[((caller callee a/b-variance) . rest)
@ -208,7 +203,6 @@
#f]
[((caller-τ callee-τ a/b-variance) . rest)
;; TODO: use this as a fallback if the "invariant" above fails?
#:when (displayln (list #'caller-τ #'callee-τ (syntax->datum #'a/b-variance)))
#:when (typecheck?/variance (syntax->datum #'a/b-variance)
#'caller-τ
#'callee-τ)
@ -232,15 +226,11 @@
{~and callee (~Any callee-tycons callee-τᵢ ...)}
a/b-variance)
. rest)
#:when (displayln #'caller)
#:when (displayln (get-arg-variances #'caller-tycons))
#:when (displayln #'callee)
#:when (displayln (get-arg-variances #'callee-tycons))
#:when (= (stx-length #'(caller-τᵢ ...)) (stx-length #'(callee-τᵢ ...)))
(continue #`((caller-τᵢ callee-τᵢ #,invariant) ... . rest)
old-solution)]
[(_ . rest)
(do-error 34)]))
(do-error)]))
(define (datum=? x y)
(equal? (syntax->datum x) (syntax->datum y)))
@ -266,7 +256,6 @@
(define (occurs-check entry orig-cs)
(match-define (list a b) entry)
(cond [(stx-contains-id? b a)
(displayln 4)
(type-error #:src (get-orig b)
#:msg (format (string-append
"couldn't unify ~~a and ~~a because one contains the other\n"

View File

@ -146,7 +146,6 @@
#'ty_a))
;; current cs
cs))))
(display'result:)(displayln (reverse as-))(displayln Xs)(displayln cs)
(list (reverse as-) Xs (free-id-table-map cs list))])]))
(define (mk-app-poly-infer-error stx expected-tys given-tys e_fn)