Fix union merging
Trying to merge (and thus resolve) applications of struct types would cause infinite looping on type instantiation if the struct type used both a union and recursion. Closes PR 13821
This commit is contained in:
parent
12e5bc645b
commit
c8e281a80e
22
collects/tests/typed-racket/succeed/pr13821.rkt
Normal file
22
collects/tests/typed-racket/succeed/pr13821.rkt
Normal file
|
@ -0,0 +1,22 @@
|
|||
#lang typed/racket
|
||||
|
||||
;; Test for PR 13821
|
||||
;;
|
||||
;; Make sure type instantiation with struct names doesn't
|
||||
;; loop forever
|
||||
|
||||
(struct: (X) union ([fst : (ISet X)] [snd : (ISet X)]) #:transparent)
|
||||
(struct: (X) intersection ([fst : (ISet X)] [snd : (ISet X)]) #:transparent)
|
||||
(struct: (X) complement ([fst : (ISet X)] [snd : (ISet X)]) #:transparent)
|
||||
(define-type (ISet X) (U (union X) (intersection X) (complement X) (Setof X)))
|
||||
|
||||
;; This involves type instantiation and could loop forever
|
||||
;; with the bug
|
||||
(: iset->set (All (X) ((ISet X) -> (Setof X))))
|
||||
(define (iset->set A)
|
||||
(union? A)
|
||||
(error 'unimplemented))
|
||||
|
||||
;; A simpler way to reproduce the problem
|
||||
(union? 5)
|
||||
|
|
@ -3,9 +3,10 @@
|
|||
(require "../utils/utils.rkt"
|
||||
(rep type-rep)
|
||||
(prefix-in c: (contract-req))
|
||||
(types subtype base-abbrev)
|
||||
(types subtype base-abbrev resolve)
|
||||
racket/match
|
||||
racket/list)
|
||||
racket/list
|
||||
(only-in unstable/match match*?))
|
||||
|
||||
|
||||
(provide/cond-contract
|
||||
|
@ -24,6 +25,15 @@
|
|||
(define (merge a b)
|
||||
(define b* (make-union* b))
|
||||
(cond
|
||||
;; If a union element is a Name application, then it should not
|
||||
;; be checked for subtyping since that can cause infinite
|
||||
;; loops if this is called during type instantiation.
|
||||
[(match*? (a b) ((App: (? Name?) _ _) b))
|
||||
(match-define (App: rator rands stx) a)
|
||||
;; However, we should check if it's a well-formed application
|
||||
;; so that bad applications are rejected early.
|
||||
(resolve-app-check-error rator rands stx)
|
||||
(cons a b)]
|
||||
[(subtype a b*) b]
|
||||
[(subtype b* a) (list a)]
|
||||
[else (cons a b)]))
|
||||
|
|
Loading…
Reference in New Issue
Block a user