From ec930fe853dc3db26b181b638f263e42fa4d1639 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Feb 2026 23:53:16 -0500 Subject: [PATCH] Avoid double-nested recursive-contract for Name types resolving to Mu --- .../typed-racket/private/type-contract.rkt | 21 ++++- .../static-contracts/combinators/name.rkt | 10 +++ .../succeed/no-double-recursive-contract.rkt | 78 +++++++++++++++++++ .../static-contract-conversion-tests.rkt | 44 ++++++++++- 4 files changed, 149 insertions(+), 4 deletions(-) create mode 100644 typed-racket-test/succeed/no-double-recursive-contract.rkt diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 460c7b383..e44d8cfbe 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -461,10 +461,25 @@ (define rv recursive-values) ;; FIXME: need special treatment for type constructors (define resolved-name (resolve-once type)) + ;; When the resolved type is a Mu, use the name-sc gen-names + ;; for the Mu variable's self-reference instead of letting the + ;; Mu case generate a separate recursive-sc. This avoids + ;; double-nested recursive-contract in the output. + (define (loop-for-name-sc resolved side rv) + (match resolved + [(Mu: (list n) b) + (loop b + side + (hash-set rv + n + (triple (lookup-name-sc type 'untyped) + (lookup-name-sc type 'typed) + (lookup-name-sc type 'both))))] + [_ (loop resolved side rv)])) (register-name-sc type - (λ () (loop resolved-name 'untyped rv)) - (λ () (loop resolved-name 'typed rv)) - (λ () (loop resolved-name 'both rv))) + (λ () (loop-for-name-sc resolved-name 'untyped rv)) + (λ () (loop-for-name-sc resolved-name 'typed rv)) + (λ () (loop-for-name-sc resolved-name 'both rv))) (lookup-name-sc type typed-side)])] ;; Ordinary type applications or struct type names, just resolve [(or (App: _ _) (Name/struct:)) (t->sc (resolve-once type))] diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt index e2c1c5fff..2f1520939 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt @@ -32,6 +32,7 @@ static-contract? static-contract?)))] [lookup-name-sc (-> Type? symbol? (or/c #f static-contract?))] + [lookup-name-def (-> Type? symbol? (or/c #f static-contract?))] [register-name-sc (-> Type? (-> static-contract?) (-> static-contract?) @@ -75,6 +76,15 @@ [(untyped) (caddr result)] [else (raise-argument-error 'lookup-name-sc "side?" typed-side)]))) +(define (lookup-name-def type typed-side) + (define result (hash-ref (name-defs-table) type #f)) + (and result + (case typed-side + [(typed) (car result)] + [(untyped) (cadr result)] + [(both) (caddr result)] + [else (raise-argument-error 'lookup-name-def "side?" typed-side)]))) + (define (register-name-sc type typed-thunk untyped-thunk both-thunk) (define typed-name (generate-temporary)) (define untyped-name (generate-temporary)) diff --git a/typed-racket-test/succeed/no-double-recursive-contract.rkt b/typed-racket-test/succeed/no-double-recursive-contract.rkt new file mode 100644 index 000000000..17243afa9 --- /dev/null +++ b/typed-racket-test/succeed/no-double-recursive-contract.rkt @@ -0,0 +1,78 @@ +#lang racket/base + +;; Test that recursive Name types produce well-formed contracts. +;; Exercises Name->Mu, Name->Name->Mu, mutually recursive names, +;; and plain Mu types. + +(require rackunit + racket/class) + +;; --------------------------------------------------------------- +;; Case 1: Name type resolving to Mu (recursive class type alias) +(module typed1 typed/racket + (require typed/racket/class) + (define-type C% (Class [m (-> (Instance C%) Void)])) + (: obj (Instance C%)) + (define obj + (new (class object% + (super-new) + (define/public (m x) (void))))) + (provide obj)) + +(require 'typed1) +(check-true (object? obj)) +(send obj m obj) + +;; --------------------------------------------------------------- +;; Case 2: Name type alias chain (Name->Name->Mu) +(module typed2 typed/racket + (require typed/racket/class) + (define-type Base% (Class [m (-> (Instance Base%) Void)])) + (define-type Alias% Base%) + (: obj2 (Instance Alias%)) + (define obj2 + (new (class object% + (super-new) + (define/public (m x) (void))))) + (provide obj2)) + +(require 'typed2) +(check-true (object? obj2)) +(send obj2 m obj2) + +;; --------------------------------------------------------------- +;; Case 3: Mutually recursive Name types +(module typed3 typed/racket + (require typed/racket/class) + (define-type A% (Class [get-b (-> (Instance B%))])) + (define-type B% (Class [get-a (-> (Instance A%))])) + (: a-obj (Instance A%)) + (: b-obj (Instance B%)) + (define b-obj + (new (class object% + (super-new) + (define/public (get-a) a-obj)))) + (define a-obj + (new (class object% + (super-new) + (define/public (get-b) b-obj)))) + (provide a-obj + b-obj)) + +(require 'typed3) +(check-true (object? a-obj)) +(check-true (object? b-obj)) +(check-true (object? (send a-obj get-b))) +(check-true (object? (send b-obj get-a))) + +;; --------------------------------------------------------------- +;; Case 4: Recursive non-class Mu type (e.g., recursive list) +;; to make sure the fix doesn't break plain Mu types +(module typed4 typed/racket + (define-type Tree (U Null (Pairof Integer Tree))) + (: t Tree) + (define t (list 1 2 3)) + (provide t)) + +(require 'typed4) +(check-equal? t '(1 2 3)) diff --git a/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt b/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt index 2332d905b..5a02d7576 100644 --- a/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt +++ b/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt @@ -11,8 +11,11 @@ typed-racket/static-contracts/instantiate typed-racket/static-contracts/structures typed-racket/static-contracts/combinators + typed-racket/static-contracts/combinators/name typed-racket/types/abbrev - typed-racket/types/numeric-tower)) + typed-racket/types/numeric-tower + typed-racket/rep/type-rep + typed-racket/env/type-name-env)) (provide tests) (gen-test-main) @@ -209,4 +212,43 @@ (t/sc (-set Univ) #:ret any/sc #:optional) (t/sc (-HT (-vec -Symbol) (-vec -Symbol)) #:ret any/sc #:optional) (t/sc (-unit null null null ManyUniv) #:ret any/sc #:optional)) + + ;; When a Name type resolves to a Mu, the name-def SC should be a + ;; plain object/sc, not wrapped in recursive-sc. The single level of + ;; recursive-contract comes from extra-defs in instantiate; verifying + ;; that the name-def is not itself a recursive-sc ensures no doubling. + (test-suite "Name->Mu produces no double recursive-sc" + (test-case "recursive class type alias" + (phase1-phase0-eval (define name-id (datum->syntax #f 'TestC%)) + (define the-type (make-Name name-id 0 #f)) + (register-type-name name-id (-mu a (-object #:method [(m (-> a -Void))]))) + (with-new-name-tables + (let () + (define sc (type->static-contract the-type (lambda (#:reason _) #f))) + ;; The top-level SC is just a name reference. + ;; Default typed-side=#t maps to 'typed. + (define typed-name-sc (lookup-name-sc the-type 'typed)) + (define both-name-sc (lookup-name-sc the-type 'both)) + ;; The name-def SC should be a plain object/sc. + ;; Before the fix, this was a recursive-sc wrapping + ;; the object/sc, which combined with the + ;; recursive-contract from extra-defs produced + ;; double nesting. + (define both-def (lookup-name-def the-type 'both)) + (define expected-def + (object/sc #t + (list (member-spec 'method + 'm + (function/sc #t + (list any/sc both-name-sc) + null + null + null + #f + (list (flat/sc #'void?))))))) + #`(begin + ;; The top-level result is a name-sc reference + (check-equal? '#,sc '#,typed-name-sc) + ;; The name-def is object/sc, not recursive-sc + (check-equal? '#,both-def '#,expected-def))))))) ))