Reorg to separate out files.

svn: r11857

collects/typed-scheme/main.ss

@@ -1,10 +1,12 @@
 #lang s-exp "minimal.ss"
            
+
+
 (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
                  (except "private/prims.ss"))
 	   (basics #%module-begin		   		   		   
 		   #%top-interaction
 		   lambda
 		   #%app))
-
+(require "private/base-env.ss" "private/base-special-env.ss")
 (provide (rename-out [with-handlers: with-handlers]))

collects/typed-scheme/minimal.ss

@@ -5,7 +5,7 @@
 
 (require (for-syntax scheme/base))
 
-(define-for-syntax ts-mod "typed-scheme.ss")
+(define-for-syntax ts-mod 'typed-scheme/typed-scheme)
 
 (define-syntax (providing stx)
   (syntax-case stx (libs from basics except)

collects/typed-scheme/private/base-env.ss

@@ -1,100 +1,18 @@
-#lang scheme/base
+#lang s-exp "env-lang.ss"
 
-;; these are libraries providing functions we add types to that are not in scheme/base
 (require
- "extra-procs.ss"
- "../utils/utils.ss"
  (only-in scheme/list cons? take drop add-between last filter-map)
  (only-in rnrs/lists-6 fold-left)
  '#%paramz
- (only-in scheme/match/runtime match:error)
  scheme/promise
- string-constants/string-constant)
+ (only-in scheme/match/runtime match:error))
-
-
-
-;; these are all for constructing the types given to variables
-(require (for-syntax
-          scheme/base
-          (env init-envs)          
-          (except-in (rep effect-rep type-rep) make-arr)
-          "type-effect-convenience.ss"
-          (only-in "type-effect-convenience.ss" [make-arr* make-arr])
-          "union.ss"
-          (typecheck tc-structs)))
-
-(define-for-syntax (initialize-others) 
-  (d-s date 
-       ([second : N] [minute : N] [hour : N] [day : N] [month : N] 
-        [year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
-       ())
-  (d-s exn ([message : -String] [continuation-marks : Univ]) ())
-  (d-s (exn:fail exn) () (-String Univ))
-  (d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
-  )
-
-(provide (for-syntax initial-env initialize-others))
-
-(define-syntax (define-initial-env stx)
-    (syntax-case stx ()
-      [(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
-       (with-syntax ([(_ make-promise . _)
-                      (local-expand #'(delay 3)
-                                    'expression
-                                    null)]
-                     [language
-                      (local-expand #'(this-language)
-                                    'expression
-                                    null)]
-                     [(_ qq-append . _)
-                      (local-expand #'`(,@'() 1)
-                                    'expression
-                                    null)])
-         #`(define-for-syntax initial-env
-             (make-env
-              [make-promise make-promise-ty]
-              [language language-ty]
-              [qq-append qq-append-ty]
-              [id ty] ...)))]))
-
-(define-for-syntax (one-of/c . args)
-  (apply Un (map -val args)))
-
-
-(define-initial-env initial-env
-  ;; make-promise
-  (-poly (a) (-> (-> a) (-Promise a)))
-  ;; language
-  Sym
-  ;; qq-append
-  (-poly (a b) 
-         (cl->*
-          (-> (-lst a) (-val '()) (-lst a))
-          (-> (-lst a) (-lst b) (-lst (*Un a b)))))
-  #|;; language
-     [(expand '(this-language))
-      Sym
-      string-constants/string-constant]
-     ;; make-promise      
-     [(cadr (syntax->list (expand '(delay 3))))
-      (-poly (a) (-> (-> a) (-Promise a)))
-      scheme/promise]
-     ;; qq-append     
-     [(cadr (syntax->list (expand '`(,@'() 1)))) 
-      (-poly (a b) 
-             (cl->*
-              (-> (-lst a) (-val '()) (-lst a))
-              (-> (-lst a) (-lst b) (-lst (*Un a b)))))]
-|#
-     
-     
 
 [raise (Univ . -> . (Un))]
 
-     (car (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v a)]
+(car (-poly (a b) (cl-> [((-pair a b)) a]
-                                        [((make-Listof (-v a))) (-v a)])))
+                        [((make-Listof a)) a])))
-     [first (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v a)]
+[first (-poly (a b) (cl-> [((-pair a b)) a]
-                                          [((make-Listof (-v a))) (-v a)]))]
+                          [((make-Listof a)) a]))]
 [second (-poly (a b c)
                (cl->                
                 [((-pair a (-pair b c))) b]
@@ -114,10 +32,10 @@
          [((-lst a)) a])))
 (caddr (-poly (a) (-> (-lst a) a)))
 (cadddr (-poly (a) (-> (-lst a) a)))
-     (cdr (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v b)]
+(cdr (-poly (a b) (cl-> [((-pair a b)) b]
-                                        [((make-Listof (-v a))) (make-Listof (-v a))])))
+                                   [((make-Listof a)) (make-Listof a)])))
-     (cddr (make-Poly (list 'a) (-> (make-Listof (-v a)) (make-Listof (-v a)))))
+(cddr (-poly (a) (-> (make-Listof a) (make-Listof a))))
-     (cdddr (make-Poly (list 'a) (-> (make-Listof (-v a)) (make-Listof (-v a)))))
+(cdddr (-poly (a) (-> (make-Listof a) (make-Listof a))))
 (cons (-poly (a b) 
              (cl-> [(a (-lst a)) (-lst a)]
                    [(a b) (-pair a b)])))
@@ -165,10 +83,10 @@
                [(-Port) -Void])]
 [not (-> Univ B)]
 [floor (-> N N)]
-     [box (-poly (a) (a . -> . (make-Box a)))]
+[box (-poly (a) (a . -> . (-box a)))]
-     [unbox (-poly (a) ((make-Box a) . -> . a))]
+[unbox (-poly (a) ((-box a) . -> . a))]
-     [set-box! (-poly (a) ((make-Box a) a . -> . -Void))]
+[set-box! (-poly (a) ((-box a) a . -> . -Void))]
-     [box? (make-pred-ty (make-Box Univ))]
+[box? (make-pred-ty (-box Univ))]
 [cons? (make-pred-ty (-pair Univ Univ))]
 [pair? (make-pred-ty (-pair Univ Univ)) #;(-poly (a b) (make-pred-ty (-pair a b)))]
 [empty? (make-pred-ty (-val null))]
@@ -237,8 +155,8 @@
 [printf (->* (list -String) Univ -Void)]
 [fprintf (->* (list -Output-Port -String) Univ -Void)]
 [format (->* (list -String) Univ -String)]   
-     (fst (make-Poly (list 'a 'b) (-> (-pair (-v a) (-v b)) (-v a))))
+(fst (-poly (a b) (-> (-pair a b) a)))
-     (snd (make-Poly (list 'a 'b) (-> (-pair (-v a) (-v b)) (-v b))))
+(snd (-poly (a b) (-> (-pair a b) b)))
 
 (= (->* (list N N) N B))
 (>= (->* (list N N) N B))
@@ -253,14 +171,14 @@
 (max (->* (list N) N N))
 (min (->* (list N) N N))
 [vector-ref 
-      (make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))]
+ (-poly (a) ((-vec a) N . -> . a))]
-     [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))]
+[build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (-vec a)))]
 [build-list (-poly (a) (-Integer (-Integer . -> . a) . -> . (-lst a)))]
-     [reverse (make-Poly '(a) (-> (make-Listof (-v a)) (make-Listof (-v a))))]
+[reverse (-poly (a) (-> (make-Listof a) (make-Listof a)))]
 [append (-poly (a) (->* (list) (-lst a) (-lst a)))]
-     [length (make-Poly '(a) (-> (make-Listof (-v a)) -Integer))]
+[length (-poly (a) (-> (make-Listof a) -Integer))]
-     [memq (make-Poly (list 'a) (-> (-v a) (make-Listof (-v a)) (-opt (make-Listof (-v a)))))]
+[memq (-poly (a) (-> a (make-Listof a) (-opt (make-Listof a))))]
-     [memv (make-Poly (list 'a) (-> (-v a) (make-Listof (-v a)) (-opt (make-Listof (-v a)))))]
+[memv (-poly (a) (-> a (make-Listof a) (-opt (make-Listof a))))]
 [memf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt (-lst a))))]
 [member 
  (-poly (a) (a (-lst a) . -> . (-opt (-lst a))))]
@@ -354,7 +272,7 @@
 [current-namespace (-Param -Namespace -Namespace)]
 [print-struct (-Param B B)]
 [read-decimal-as-inexact (-Param B B)]
-     [current-command-line-arguments (-Param (make-Vector -String) (make-Vector -String))]
+[current-command-line-arguments (-Param (-vec -String) (-vec -String))]
 
 ;; regexp stuff
 [regexp-match 
@@ -389,14 +307,14 @@
 
 [match:error ((list) Univ . ->* . (Un))]
 
-     [vector-set! (-poly (a) (-> (make-Vector a) N a -Void))]
+[vector-set! (-poly (a) (-> (-vec a) N a -Void))]
 
-     [vector->list (-poly (a) (-> (make-Vector a) (-lst a)))]
+[vector->list (-poly (a) (-> (-vec a) (-lst a)))]
-     [list->vector (-poly (a) (-> (-lst a) (make-Vector a)))]
+[list->vector (-poly (a) (-> (-lst a) (-vec a)))]
 [exact? (N . -> . B)]
 [inexact? (N . -> . B)]
 [expt (cl->* (-Integer -Integer . -> . -Integer) (N N . -> . N))]
-     [vector (-poly (a) (->* (list) a (make-Vector a)))]
+[vector (-poly (a) (->* (list) a (-vec a)))]
 [real? (Univ . -> . B)]
 [real-part (N . -> . N)]
 [imag-part (N . -> . N)]
@@ -419,13 +337,13 @@
 [make-vector
  (-poly (a)
         (cl->
-              [(N) (make-Vector N)]
+         [(N) (-vec N)]
-              [(N a) (make-Vector a)]))]
+         [(N a) (-vec a)]))]
 
 [file-exists? (-Pathlike . -> . B)]
 [string->symbol (-String . -> . Sym)]
 [symbol->string (Sym . -> . -String)]
-     [vector-length (-poly (a) ((make-Vector a) . -> . N))]
+[vector-length (-poly (a) ((-vec a) . -> . N))]
 
 [call-with-input-file (-poly (a) 
                              (cl->
@@ -563,12 +481,3 @@
 
 [eof (-val eof)]
 [read-accept-reader (-Param B B)]
-     )
-
-(begin-for-syntax 
-  #;(printf "running base-env~n")
-  (initialize-type-env initial-env)
-  (initialize-others))
-
-
-

collects/typed-scheme/private/base-special-env.ss

@@ -0,0 +1,83 @@
+#lang scheme/base
+
+;; these are libraries providing functions we add types to that are not in scheme/base
+(require
+ "extra-procs.ss"
+ "../utils/utils.ss"
+ (only-in scheme/list cons? take drop add-between last filter-map)
+ (only-in rnrs/lists-6 fold-left)
+ '#%paramz
+ (only-in scheme/match/runtime match:error)
+ scheme/promise
+ string-constants/string-constant)
+
+
+
+;; these are all for constructing the types given to variables
+(require (for-syntax
+          scheme/base
+          (env init-envs)          
+          (except-in (rep effect-rep type-rep) make-arr)
+          "type-effect-convenience.ss"
+          (only-in "type-effect-convenience.ss" [make-arr* make-arr])
+          "union.ss"
+          (typecheck tc-structs)))
+
+(define-for-syntax (initialize-others) 
+  (d-s date 
+       ([second : N] [minute : N] [hour : N] [day : N] [month : N] 
+        [year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
+       ())
+  (d-s exn ([message : -String] [continuation-marks : Univ]) ())
+  (d-s (exn:fail exn) () (-String Univ))
+  (d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
+  )
+
+(provide (for-syntax initial-env/special-case initialize-others initialize-type-env)
+         define-initial-env)
+
+(define-syntax (define-initial-env stx)
+    (syntax-case stx ()
+      [(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
+       (with-syntax ([(_ make-promise . _)
+                      (local-expand #'(delay 3)
+                                    'expression
+                                    null)]
+                     [language
+                      (local-expand #'(this-language)
+                                    'expression
+                                    null)]
+                     [(_ qq-append . _)
+                      (local-expand #'`(,@'() 1)
+                                    'expression
+                                    null)])
+         #`(define-for-syntax initial-env
+             (make-env
+              [make-promise make-promise-ty]
+              [language language-ty]
+              [qq-append qq-append-ty]
+              [id ty] ...)))]))
+
+
+
+
+(define-initial-env initial-env/special-case
+  ;; make-promise
+  (-poly (a) (-> (-> a) (-Promise a)))
+  ;; language
+  Sym
+  ;; qq-append
+  (-poly (a b) 
+         (cl->*
+          (-> (-lst a) (-val '()) (-lst a))
+          (-> (-lst a) (-lst b) (-lst (*Un a b))))))
+     
+     
+     
+
+(begin-for-syntax   
+  (initialize-type-env initial-env/special-case)
+  (initialize-others))
+
+
+

collects/typed-scheme/private/env-lang.ss

@@ -0,0 +1,34 @@
+#lang scheme/base
+
+(require "../utils/utils.ss")
+
+(require (for-syntax (private type-effect-convenience)
+                     (env init-envs)
+                     scheme/base
+                     (except-in (rep effect-rep type-rep) make-arr)
+                     "type-effect-convenience.ss"
+                     (only-in "type-effect-convenience.ss" [make-arr* make-arr])
+                     "union.ss"))
+(define-syntax (#%module-begin stx)
+  (syntax-case stx (require)
+    [(mb (require . args) [id ty] ...)
+     (begin
+       (unless (andmap identifier? (syntax->list #'(id ...)))
+         (raise-syntax-error #f "not all ids"))
+       #'(#%plain-module-begin
+          (begin
+            (require . args)
+            (define-for-syntax e
+              (make-env [id ty] ...))
+            (begin-for-syntax
+              (initialize-type-env e)))))]
+    [(mb . rest)
+     #'(mb (require) . rest)]))
+
+(provide #%module-begin
+         require
+         (all-from-out scheme/base)
+         (for-syntax
+          (all-from-out scheme/base
+                        "type-effect-convenience.ss"
+                        "union.ss")))

collects/typed-scheme/private/type-effect-convenience.ss

@@ -13,7 +13,12 @@
          (for-syntax macro-debugger/stxclass/stxclass)
          (for-syntax scheme/base))
 
-(provide (all-defined-out))
+(provide (all-defined-out) 
+         ;; these should all eventually go away
+         make-Name make-ValuesDots make-Function make-top-arr make-Latent-Restrict-Effect make-Latent-Remove-Effect)
+
+(define (one-of/c . args)
+  (apply Un (map -val args)))
 
 (define (-vet id) (make-Var-True-Effect id))
 (define (-vef id) (make-Var-False-Effect id))
@@ -206,6 +211,8 @@
 
 (define (-Tuple l)
   (foldr -pair (-val '()) l))
+(define -box make-Box)
+(define -vec make-Vector)
 
 (define Any-Syntax 
   (-mu x

collects/typed-scheme/typed-scheme.ss

@@ -2,7 +2,7 @@
 
 (require (rename-in "utils/utils.ss" [infer r:infer]))
 
-(require (private base-env base-types)
+(require (private #;base-env base-types)
          (for-syntax 
           scheme/base
 	  (private type-utils type-contract type-effect-convenience)