From 08bec9de9cc7a7bb93ff014ab1cab3287d9355d0 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Sun, 13 Apr 2014 12:07:48 -0400
Subject: [PATCH] Reduce dependencies of TR's base-contracted.rkt

This reduces the dependencies of typed/racket/base. Avoid
bringing in type environment dependencies by manually constructing
a #%type-decl submodule.
---
 .../typed-racket/base-env/base-contracted.rkt | 62 +++++++++----------
 .../typed-racket/base-env/prims.rkt           |  2 +-
 .../typed-racket/standard-inits.rkt           |  3 -
 3 files changed, 31 insertions(+), 36 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-contracted.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-contracted.rkt
index e3b8370301..e823f70a95 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-contracted.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-contracted.rkt
@@ -4,44 +4,42 @@
 ;; contract protection, even in typed code.
 
 (require "../utils/utils.rkt"
-         (env init-envs)
-         (types abbrev)
          (utils any-wrap)
-         (only-in (rep type-rep)
-                  make-Prompt-Tagof))
+         (prefix-in c: racket/contract)
+         (rename-in
+          racket/base
+          [default-continuation-prompt-tag -default-continuation-prompt-tag])
+         (for-syntax racket/base
+                     (env env-req)))
 
-;; this submodule defines the contracted versions
-(module contracted racket/base
-  (require racket/contract
-           (rename-in
-            racket/base
-            [default-continuation-prompt-tag -default-continuation-prompt-tag])
-           "../utils/utils.rkt"
-           (utils any-wrap))
+(provide default-continuation-prompt-tag)
 
-  (provide default-continuation-prompt-tag)
-
-  ;; default tag should use Any wrappers
-  (define default-continuation-prompt-tag
-    (contract (-> (prompt-tag/c any-wrap/c #:call/cc any-wrap/c))
+;; default tag should use Any wrappers
+(define default-continuation-prompt-tag
+  (c:contract (c:-> (c:prompt-tag/c any-wrap/c #:call/cc any-wrap/c))
               -default-continuation-prompt-tag
               ;; TODO: we actually want to be able to specify that the
               ;;       "contract from" party is not the untyped party
               ;;       here, but that's not currently possible
-              'untyped 'typed)))
+              'untyped 'typed))
 
-(require (for-template (submod "." contracted))
-         (submod "." contracted))
+(begin-for-syntax
+  (add-mod! (variable-reference->module-path-index (#%variable-reference))))
 
-(provide default-continuation-prompt-tag)
-
-;; set up the type environment
-(define-initial-env initialize-contracted
-  [default-continuation-prompt-tag
-    ;; TODO: we actually want the type
-    ;;       for the handler (->* (list) Univ ManyUniv)
-    ;;       but the prompt tag contract doesn't quite
-    ;;       support this (it needs a #:rest argument)
-    ;;
-    ;;       Also, this type works better with inference.
-    (-> (make-Prompt-Tagof Univ (-> Univ ManyUniv)))])
+;; Set up a #%type-decl manually to avoid the overhead of bringing in
+;; the "extra-env-lang.rkt" module
+(begin-for-syntax
+  (module* #%type-decl #f
+    (#%plain-module-begin
+     (require typed-racket/env/global-env
+              typed-racket/types/abbrev
+              typed-racket/rep/type-rep)
+     (register-type
+      (quote-syntax default-continuation-prompt-tag)
+      ;; TODO: we actually want the type
+      ;;       for the handler (->* (list) Univ ManyUniv)
+      ;;       but the prompt tag contract doesn't quite
+      ;;       support this (it needs a #:rest argument)
+      ;;
+      ;;       Also, this type works better with inference.
+      (-> (make-Prompt-Tagof Univ (-> Univ ManyUniv)))))))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
index 6c07a59fe3..77f71082c7 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
@@ -99,7 +99,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
          "../typecheck/internal-forms.rkt"
          (rename-in racket/contract/base [-> c->] [->* c->*] [case-> c:case->])
          ;; contracted bindings to replace built-in ones
-         (except-in "base-contracted.rkt" initialize-contracted)
+         "base-contracted.rkt"
          "top-interaction.rkt"
          "base-types.rkt"
          "base-types-extra.rkt"
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/standard-inits.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/standard-inits.rkt
index 86a05739b9..ebe23afadf 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/standard-inits.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/standard-inits.rkt
@@ -13,7 +13,6 @@
   [typed-racket/base-env/base-structs (initialize-structs)]
   [typed-racket/base-env/base-env-indexing (initialize-indexing)]
   [typed-racket/base-env/base-special-env (initialize-special)]
-  [typed-racket/base-env/base-contracted (initialize-contracted)]
   [(submod typed-racket/base-env/base-types initialize) (initialize-type-names)])
 
 (define initialized #f)
@@ -30,8 +29,6 @@
     (do-time "Finshed base-env-numeric")
     (initialize-special)
     (do-time "Finished base-special-env")
-    (initialize-contracted)
-    (do-time "Finished base-contracted")
     (initialize-type-names)
     (do-time "Finished base-types")
     (set! initialized #t))