From 3c074249a01246d289f45fda4586457048661c50 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 29 Mar 2016 13:36:53 -0500
Subject: [PATCH] Make contract obligation tests more mobust.

---
 .../tests/racket/contract/obligations.rkt     | 21 ++++++++++++-------
 .../tests/racket/contract/test-util.rkt       |  6 +++---
 2 files changed, 16 insertions(+), 11 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/obligations.rkt b/pkgs/racket-test/tests/racket/contract/obligations.rkt
index 4b11f7e406..97a74735b0 100644
--- a/pkgs/racket-test/tests/racket/contract/obligations.rkt
+++ b/pkgs/racket-test/tests/racket/contract/obligations.rkt
@@ -1,11 +1,12 @@
 #lang racket/base
-(require "test-util.rkt")
+(require "test-util.rkt"
+         racket/list)
 
 (parameterize ([current-contract-namespace
                 (make-basic-contract-namespace)])
 (define (test-obligations quoted-expr expected-props)
   
-  (define (cleanup key obj stx)
+  (define ((cleanup key stx) obj)
     (case key
       [(racket/contract:contract)
        (define (cleanup-ent x)
@@ -21,21 +22,25 @@
        (error 'test-obligations "unknown property ~s" key)]))
   
   (let ([props '()])
-    (let ([stx (contract-expand-once quoted-expr)])
+    (let ([stx (contract-expand quoted-expr)])
       (let loop ([stx stx])
         (cond
           [(syntax? stx)
-           (for ([key (in-list (syntax-property-symbol-keys stx))])
-             (when (regexp-match #rx"^racket/contract:" (symbol->string key))
-               (set! props (cons (cleanup key (syntax-property stx key) stx)
-                                 props))))
+           (syntax-case stx (#%top)
+             [(#%top . x)
+              (void)]
+             [_
+              (for ([key (in-list (syntax-property-symbol-keys stx))])
+                (when (regexp-match #rx"^racket/contract:" (symbol->string key))
+                  (set! props (append (map (cleanup key stx) (flatten (syntax-property stx key)))
+                                      props))))])
            (loop (syntax-e stx))]
           [(pair? stx)
            (loop (car stx))
            (loop (cdr stx))])))
     (test expected-props
           `(obligations-for ,quoted-expr)
-          (sort props string<=? #:key (λ (x) (format "~s" x))))))
+          (remove-duplicates (sort props string<=? #:key (λ (x) (format "~s" x)))))))
 
   (test-obligations '(-> a b)
                     '((racket/contract:contract (->) ())
diff --git a/pkgs/racket-test/tests/racket/contract/test-util.rkt b/pkgs/racket-test/tests/racket/contract/test-util.rkt
index 2f07a12c9b..1237139dc6 100644
--- a/pkgs/racket-test/tests/racket/contract/test-util.rkt
+++ b/pkgs/racket-test/tests/racket/contract/test-util.rkt
@@ -20,7 +20,7 @@
          
          contract-eval
          contract-compile
-         contract-expand-once
+         contract-expand
          
          rewrite-to-add-opt/c
          rewrite-to-double-wrap
@@ -126,9 +126,9 @@
   (parameterize ([current-namespace (current-contract-namespace)])
     (compile x)))
 
-(define (contract-expand-once x)
+(define (contract-expand x)
   (parameterize ([current-namespace (current-contract-namespace)])
-    (expand-once x)))
+    (expand x)))
 
 (define-syntax (ctest stx)
   (syntax-case stx ()