From 8c952357502c68fbe1906d866ea1372fe3283855 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Sun, 15 Jul 2012 10:25:11 -0700
Subject: [PATCH] Cleanup builtin structs types.

original commit: a408d6bfbfacae706b8d1d51f67c7929c3fcae16
---
 collects/typed-racket/base-env/base-env.rkt   | 20 ++++++++++++-------
 .../typed-racket/base-env/base-structs.rkt    | 11 +++++++---
 2 files changed, 21 insertions(+), 10 deletions(-)

diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt
index c435866d..19b5f1f6 100644
--- a/collects/typed-racket/base-env/base-env.rkt
+++ b/collects/typed-racket/base-env/base-env.rkt
@@ -23,6 +23,7 @@
   (only-in string-constants/private/only-once maybe-print-message)
   (only-in mzscheme make-namespace)
   (only-in racket/match/runtime match:error matchable? match-equality-test))
+ "base-structs.rkt"
  racket/file
  (only-in racket/private/pre-base new-apply-proc)
  (only-in (types abbrev) [-Boolean B] [-Symbol Sym])
@@ -390,7 +391,6 @@
 
 [list? (make-pred-ty (-lst Univ))]
 [list (-poly (a) (->* '() a (-lst a)))]
-[procedure? (make-pred-ty top-func)]
 [map (-polydots (c a b)
                 (cl->*
                  (-> (-> a c) (-pair a (-lst a)) (-pair c (-lst c)))
@@ -570,6 +570,16 @@
 [assf  (-poly (a b) ((a . -> . Univ) (-lst (-pair a b))
                      . -> . (-opt (-pair a b))))]
 
+;Procedures Section 3.17
+[procedure? (make-pred-ty top-func)]
+[compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))]
+[compose1 (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))]
+[procedure-arity (-> top-func (Un -Nat -Arity-At-Least (-lst (Un -Nat -Arity-At-Least))))]
+[procedure-arity? (make-pred-ty (Un -Nat -Arity-At-Least (-lst (Un -Nat -Arity-At-Least))))]
+[procedure-arity-includes? (->opt top-func -Nat [Univ] B)]
+[procedure-reduce-arity (-> top-func (Un -Nat -Arity-At-Least (-lst (Un -Nat -Arity-At-Least))) top-func)]
+[procedure-keywords (-> top-func (-values (list (-lst -Keyword) (-opt (-lst -Keyword)))))]
+
 [apply        (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
 [new-apply-proc (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
 [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
@@ -701,8 +711,8 @@
 
 
 
-[seconds->date (cl->* (-Integer . -> . (make-Name #'date))
-                      (-Integer Univ . -> . (make-Name #'date)))]
+[seconds->date (cl->* (-Integer . -> . -Date)
+                      (-Integer Univ . -> . -Date))]
 [current-seconds (-> -Integer)]
 
 ;Section 14.2
@@ -1994,10 +2004,6 @@
 ;Section 13.9 (Code Inspectors)
 [current-code-inspector (-Param -Inspector -Inspector)]
 
-
-[compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))]
-
-
 ;ephemerons
 [make-ephemeron (-poly (k v) (-> k v (make-Ephemeron v)))]
 [ephemeron? (make-pred-ty (make-Ephemeron Univ))]
diff --git a/collects/typed-racket/base-env/base-structs.rkt b/collects/typed-racket/base-env/base-structs.rkt
index 5cfc8349..1cd5dc13 100644
--- a/collects/typed-racket/base-env/base-structs.rkt
+++ b/collects/typed-racket/base-env/base-structs.rkt
@@ -4,15 +4,15 @@
  "../utils/utils.rkt"
  (utils tc-utils)
  (env init-envs)
- (except-in (rep filter-rep object-rep type-rep) make-arr)
- (rename-in (types abbrev numeric-tower union) [make-arr* make-arr])
+ (rep filter-rep object-rep type-rep)
+ (types abbrev numeric-tower union)
  (typecheck tc-structs)
  ;;For tests
  (prefix-in k: '#%kernel))
 
 (require (for-template racket/base (prefix-in k: '#%kernel)))
 
-(provide initialize-structs)
+(provide initialize-structs -Date -Srcloc -Date -Arity-At-Least)
 
 (define-syntax define-hierarchy
   (syntax-rules (define-hierarchy)
@@ -37,6 +37,11 @@
          ...)
        ...)]))
 
+(define -Srcloc (make-Name #'srcloc))
+(define -Date (make-Name #'date))
+(define -Arity-At-Least (make-Name #'arity-at-least))
+(define -Exn (make-Name #'exn))
+
 
 (define (initialize-structs)