From a59ae821dfb223daa5e54a9c52443815e8ebc729 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Wed, 30 Oct 2013 13:34:28 -0400
Subject: [PATCH] Add a #lang for additional base type environments

These are for base type environments that get required
rather than loaded with #lang typed/racket.

original commit: 91a1ff262bc42cb3ca5ccfbcdc85c7a592a54bc7
---
 .../typed-racket/base-env/extra-env-lang.rkt  | 52 +++++++++++++++++++
 1 file changed, 52 insertions(+)
 create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt
new file mode 100644
index 00000000..eaf5213c
--- /dev/null
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt
@@ -0,0 +1,52 @@
+#lang racket/base
+
+;; This module defines a #lang for use in defining extra base
+;; type environments that will only be included on a `require`
+;; (unlike the monolithic base type environment in base-env.rkt)
+;;
+;; Also see env-lang.rkt
+
+(require "../utils/utils.rkt"
+         (for-syntax (private parse-type))
+         (for-syntax racket/base syntax/parse)
+         (types abbrev numeric-tower union filter-ops)
+         (for-syntax (types abbrev numeric-tower union filter-ops)))
+
+(provide (rename-out [-#%module-begin #%module-begin])
+         require
+         (for-syntax parse-type) ; to allow resolution of Name types
+         (except-out (all-from-out racket/base) #%module-begin)
+         (for-syntax (except-out (all-from-out racket/base) #%module-begin))
+         types rep private utils
+         (for-syntax (types-out abbrev numeric-tower union filter-ops)))
+
+(define-syntax (-#%module-begin stx)
+  (define-syntax-class clause
+    #:description "[id type]"
+    (pattern [id:identifier ty]
+             #:with register #'(register-type (quote-syntax id) ty)))
+  (syntax-parse stx #:literals (require provide begin)
+    [(mb (~optional
+          (~and extra (~or (begin . _)
+                           (require . args)
+                           (provide . args)))
+          #:defaults ([extra #'(void)]))
+         ~! binding:clause ...)
+     #'(#%plain-module-begin
+        extra
+        (require (for-syntax typed-racket/env/env-req))
+        (begin-for-syntax
+         (module* #%type-decl #f
+           (#%plain-module-begin ;; avoid top-level printing and config
+            (require typed-racket/types/numeric-tower typed-racket/env/type-name-env
+                     typed-racket/env/global-env typed-racket/env/type-alias-env
+                     typed-racket/types/struct-table typed-racket/types/abbrev
+                     (rename-in racket/private/sort [sort raw-sort]))
+            ;; FIXME: add a switch to turn contracts on for testing
+            binding.register ...)))
+        (begin-for-syntax (add-mod! (variable-reference->module-path-index
+                                     (#%variable-reference))))
+        (provide binding.id ...))]
+    [(mb . rest)
+     #'(mb (begin) . rest)]))
+