From f7019a6a2bd18b4994730ababc81de7e8342c63c Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 12 Jun 2009 20:53:47 +0000
Subject: [PATCH] Merge in changes to Syntax types from Carl.

svn: r15156

original commit: bc6d606a604a999da46a18b7d01b8d39c7b0b7cb
---
 collects/typed-scheme/private/base-env.ss   | 13 ++++++---
 collects/typed-scheme/private/base-types.ss |  8 ++++--
 collects/typed-scheme/types/abbrev.ss       | 16 +-----------
 collects/typed-scheme/types/convenience.ss  | 29 ++++++++++++++++++++-
 4 files changed, 45 insertions(+), 21 deletions(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index a1ae2671..8db019f0 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -543,9 +543,11 @@
 [datum->syntax 
  (-poly 
   (a)
-  (let* ([I (-Syntax Sym)]
+  (let* ([Pre Syntax-Sexp]
+         [I (-Syntax Sym)]
+         [A Any-Syntax]
 	 [S (-Syntax Univ)]
-	 [ctxt (-opt S)]
+         [ctxt (-opt S)]
 	 [srclist (-Tuple (list
                            Univ 
                            (-opt -Integer)
@@ -557,15 +559,20 @@
 	 [cert (-opt S)])
     (cl->*
      (-> ctxt Sym I)
+     (-> ctxt Pre A)
      (-> ctxt Univ S)
      (-> ctxt Sym srcloc I)
+     (-> ctxt Pre srcloc A)
      (-> ctxt Univ srcloc S)
      (-> ctxt Sym srcloc prop I)
+     (-> ctxt Pre srcloc prop A)
      (-> ctxt Univ srcloc prop S)
      (-> ctxt Sym srcloc prop cert I)
+     (-> ctxt Pre srcloc prop cert A)
      (-> ctxt Univ srcloc prop cert S))))]
 
-[syntax->datum (-> (-Syntax Univ) Univ)]
+[syntax->datum (cl->* (-> Any-Syntax -Sexp)
+                      (-> (-Syntax Univ) Univ))]
 [syntax-e (-poly (a) (-> (-Syntax a) a))]
 [syntax-original? (-poly (a) (-> (-Syntax a) B))]
 [identifier? (make-pred-ty (-Syntax Sym))]
diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss
index 643892b2..6180b39b 100644
--- a/collects/typed-scheme/private/base-types.ss
+++ b/collects/typed-scheme/private/base-types.ss
@@ -17,8 +17,12 @@
 [Output-Port -Output-Port]
 [Bytes -Bytes]
 [EOF (-val eof)]
-[Syntax Any-Syntax]
-[Syntaxof (-poly (a) (-Syntax a))]
+[Sexpof (-poly (a) (-Sexpof a))]   ;; recursive union of sexps with a
+[Syntaxof (-poly (a) (-Syntax a))] ;; syntax-e yields a
+[Syntax-E In-Syntax] ;; possible results of syntax-e on "2D" syntax
+[Syntax Any-Syntax]  ;; (Syntaxof Syntax-E): "2D" syntax
+[Datum Syntax-Sexp]  ;; (Sexpof Syntax), datum->syntax yields "2D" syntax
+[Sexp -Sexp]         ;; (Sexpof (U)), syntax->datum of "2D" syntax
 [Identifier Ident]
 [Procedure top-func]
 [Keyword -Keyword]
diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss
index d95a254b..75149588 100644
--- a/collects/typed-scheme/types/abbrev.ss
+++ b/collects/typed-scheme/types/abbrev.ss
@@ -18,6 +18,7 @@
 ;; convenient constructors
 
 
+(define -App make-App)
 (define -pair make-Pair)
 (define -val make-Value)
 (define -Param make-Param)
@@ -98,21 +99,6 @@
 (define -Nat -Integer)
 (define -Real -Number)
 
-(define Any-Syntax
-  (-mu x
-       (-Syntax (*Un 
-                 -Number
-                 -Boolean
-                 -Symbol
-                 -String
-		 -Keyword                 
-                 (-mu y (*Un (-val '()) (-pair x (*Un x y))))
-                 (make-Vector x)
-                 (make-Box x)))))
-
-(define Ident (-Syntax -Symbol))
-
-(define -Sexp (-mu x (*Un (-val null) -Number -Boolean -Symbol -String (-pair x x))))
 (define -Port (*Un -Output-Port -Input-Port))
 
 (define -Pathlike (*Un -String -Path))
diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss
index 12184a72..b7c0b470 100644
--- a/collects/typed-scheme/types/convenience.ss
+++ b/collects/typed-scheme/types/convenience.ss
@@ -44,4 +44,31 @@
 
 
 ;; DO NOT USE if t contains #f
-(define (-opt t) (Un (-val #f) t))
\ No newline at end of file
+(define (-opt t) (Un (-val #f) t))
+
+(define In-Syntax
+  (-mu e
+       (*Un -Number -Boolean -Symbol -String -Keyword -Char
+            (make-Vector (-Syntax e))
+            (make-Box (-Syntax e))
+            (-mu list
+                 (*Un (-val '())
+                      (-pair (-Syntax e)
+                             (*Un (-Syntax e) list)))))))
+
+(define Any-Syntax (-Syntax In-Syntax))
+
+(define (-Sexpof t)
+  (-mu sexp
+       (Un -Number -Boolean -Symbol -String -Keyword -Char
+           (-val '())
+           (-pair sexp sexp)
+           (make-Vector sexp)
+           (make-Box sexp)
+           t)))
+
+(define -Sexp (-Sexpof (Un)))
+
+(define Syntax-Sexp (-Sexpof Any-Syntax))
+
+(define Ident (-Syntax -Symbol))