From 482a9111d7f5dd671bd15decb07dc9998b634c8b Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Thu, 14 Nov 2013 22:55:15 -0800
Subject: [PATCH] Cleanup duplication in check-subforms-unit.

original commit: 1d0164f51b9730aa35324bda6222a5b3d718f924
---
 .../typecheck/check-subforms-unit.rkt         | 94 +++++++++----------
 1 file changed, 45 insertions(+), 49 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
index 21ac85ea..70ae21dc 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
@@ -8,6 +8,7 @@
          (types utils abbrev union resolve)
          (private syntax-properties)
          (utils tc-utils)
+         (for-syntax racket/base syntax/parse)
          (rep type-rep))
 
 (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
@@ -32,6 +33,20 @@
        (ret (map (lambda (ts) (apply Un ts)) ts*)))]
     [_ (int-err "Internal error: unsupported exception result type in: ~a" args)]))
 
+;; Does a depth first search of the syntax object. For each sub object it attempts to match it
+;; against the provide syntax-parse patterns.
+(define-syntax find-syntax
+  (syntax-parser
+    [(_ init-form [clause bodies ...+] ...)
+     #'(let loop ([form init-form])
+         (parameterize ([current-orig-stx form])
+           (syntax-parse form
+             [clause bodies ...] ...
+             [(a . b)
+              (loop #'a)
+              (loop #'b) ]
+             [_ (void)])))]))
+
 ;; find the subexpressions that need to be typechecked in an ignored form
 ;; syntax -> any
 (define (check-subforms/with-handlers form [expected #f])
@@ -51,61 +66,42 @@
         [(or (Poly: ns _) (PolyDots: (list ns ... _) _))
          (loop (instantiate-poly t (map (λ (n) Univ) ns)))]
         [_ (int-err "Unsupported function type in get-result-ty: \n~a" t)])))
-  (let loop ([form form])
-    (parameterize ([current-orig-stx form])
-      (syntax-parse form
-        ;; if this needs to be checked
-        [stx:with-type^
-         ;; the form should be already ascribed the relevant type
-         (tc-expr form)]
-        ;; this is a handler function
-        [stx:exn-handler^
-         (let ([t (single-value form)])
-           (match t
-             [(tc-result1: t)
-              (set! handler-tys (cons (get-result-ty t) handler-tys))]))]
-        ;; this is the body of the with-handlers
-        [stx:exn-body^
-         (set! body-stx form)
-         (set! body-ty (tc-expr form))]
-        [(a . b)
-         (loop #'a)
-         (loop #'b)]
-        [_ (void)])))
+  (find-syntax form
+    ;; if this needs to be checked
+    [stx:with-type^
+     ;; the form should be already ascribed the relevant type
+     (tc-expr #'stx)]
+    ;; this is a handler function
+    [stx:exn-handler^
+     (match (single-value #'stx)
+       [(tc-result1: t)
+        (set! handler-tys (cons (get-result-ty t) handler-tys))])]
+    ;; this is the body of the with-handlers
+    [stx:exn-body^
+     (set! body-stx #'stx)
+     (set! body-ty (tc-expr #'stx))])
   (apply combine-types body-ty handler-tys))
 
 ;; syntax tc-results -> tc-results
 (define (check-subforms/with-handlers/check form expected)
-  (let loop ([form form])
-    (parameterize ([current-orig-stx form])
-      (syntax-parse form
-        ;; if this needs to be checked
-        [stx:with-type^
-         ;; the form should be already ascribed the relevant type
-         (tc-expr form)]
-        ;; this is a handler function
-        [stx:exn-handler^
-         (tc-expr/check form (ret (-> (Un) (tc-results->values expected))))]
-        ;; this is the body of the with-handlers
-        [stx:exn-body^
-         (tc-expr/check form expected)]
-        [(a . b)
-         (begin
-           (loop #'a)
-           (loop #'b))]
-        [_ (void)])))
+  (find-syntax form
+    ;; if this needs to be checked
+    [stx:with-type^
+     ;; the form should be already ascribed the relevant type
+     (tc-expr #'stx)]
+    ;; this is a handler function
+    [stx:exn-handler^
+     (tc-expr/check #'stx (ret (-> (Un) (tc-results->values expected))))]
+    ;; this is the body of the with-handlers
+    [stx:exn-body^
+     (tc-expr/check #'stx expected)])
   expected)
 
 ;; typecheck the expansion of a with-handlers form
 ;; syntax -> void
 (define (check-subforms/ignore form)
-  (let loop ([form form])
-    (syntax-parse form
-      ;; if this needs to be checked
-      [stx:with-type^
-       ;; the form should be already ascribed the relevant type
-       (void (tc-expr form))]
-      [(a . b)
-       (loop #'a)
-       (loop #'b)]
-      [_ (void)])))
+  (find-syntax form
+    ;; if this needs to be checked
+    [stx:with-type^
+     ;; the form should be already ascribed the relevant type
+     (void (tc-expr #'stx))]))