From 0343ae06f39e5b7d93a44072e505e354a7666bc1 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Sat, 21 Feb 2009 23:55:32 +0000
Subject: [PATCH] Remove macro-debugger require. Use `this-syntax' More
 contract renamers Finish type-abbrev.ss

svn: r13785
---
 collects/typed-scheme/private/type-abbrev.ss | 261 +++++++++----------
 collects/typed-scheme/rep/interning.ss       |   2 +-
 collects/typed-scheme/rep/rep-utils.ss       |  15 +-
 collects/typed-scheme/utils/utils.ss         |  19 +-
 4 files changed, 147 insertions(+), 150 deletions(-)

diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss
index 85dd5283c6..1770757248 100644
--- a/collects/typed-scheme/private/type-abbrev.ss
+++ b/collects/typed-scheme/private/type-abbrev.ss
@@ -2,113 +2,66 @@
 
 (require "../utils/utils.ss")
 
-(require (rep type-rep effect-rep)
+(require (rep type-rep object-rep filter-rep printer)
          (utils tc-utils)
          scheme/list
-         scheme/match
-         "type-effect-printer.ss"
+         scheme/match         
          scheme/promise
+         (prefix-in c: scheme/contract)
          (for-syntax scheme/base stxclass)
 	 (for-template scheme/base scheme/contract scheme/tcp))
 
 (provide (all-defined-out))
 
-(define top-func (make-Function (list (make-top-arr))))
+;; convenient constructors
 
-(define (-vet id) (make-Var-True-Effect id))
-(define (-vef id) (make-Var-False-Effect id))
+(define -values make-Values)
+(define -pair make-Pair)
+(define -struct make-Struct)
+(define -val make-Value)
+(define -lst make-Listof)
+(define -Param make-Param)
+(define -box make-Box)
+(define -vec make-Vector)
+(define -LFS make-LFilterSet)
 
-(define -rem make-Remove-Effect)
-(define -rest make-Restrict-Effect)
+(define-syntax *Un
+  (syntax-rules ()
+    [(_ . args) (make-Union (list . args))]))
 
-(define (var->type-eff eff)
-  (match eff
-    [(Var-True-Effect: v) (make-Remove-Effect (make-Value #f) v)]
-    [(Var-False-Effect: v) (make-Restrict-Effect (make-Value #f) v)]
-    [_ eff]))
 
-(define ((add-var v) eff)
-  (match eff
-    [(Latent-Var-True-Effect:) (-vet v)]
-    [(Latent-Var-False-Effect:) (-vef v)]
-    [(Latent-Restrict-Effect: t) (make-Restrict-Effect t v)]
-    [(Latent-Remove-Effect: t) (make-Remove-Effect t v)]
-    [(True-Effect:) eff]
-    [(False-Effect:) eff]
-    [_ (int-err "can't add var ~a to effect ~a" v eff)]))
+(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
 
-(define-syntax (-> stx)
-  (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
-    [(_ dom ... rng : eff1 eff2)
-     #'(->* (list dom ...) rng : eff1 eff2)]
-    [(_ dom ... rng : eff1 eff2)
-     #'(->* (list dom ...) rng : eff1 eff2)]
-    [(_ dom ... rng)
-     #'(->* (list dom ...) rng)]))
+(define (-lst* #:tail [tail (-val null)] . args)
+  (if (null? args)
+      tail
+      (-pair (car args) (apply -lst* #:tail tail (cdr args)))))
 
-(define-syntax ->*
-  (syntax-rules (:)
-    [(_ dom rng)       
-     (make-Function (list (make-arr* dom rng)))]
-    [(_ dom rst rng)
-     (make-Function (list (make-arr* dom rng rst)))]
-    [(_ dom rng : eff1 eff2)
-     (make-Function (list (make-arr* dom rng #f eff1 eff2)))]
-    [(_ dom rst rng : eff1 eff2)
-     (make-Function (list (make-arr* dom rng rst eff1 eff2)))]))
-(define-syntax ->...
-  (syntax-rules (:)
-    [(_ dom rng)
-     (->* dom rng)]
-    [(_ dom (dty dbound) rng)
-     (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) (list) (list))))]
-    [(_ dom rng : eff1 eff2)
-     (->* dom rng : eff1 eff2)]
-    [(_ dom (dty dbound) rng : eff1 eff2)
-     (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) eff1 eff2)))]))
-(define-syntax cl->
-  (syntax-rules (:)
-    [(_ [(dom ...) rng] ...)
-     (make-Function (list (make-arr* (list dom ...) rng) ...))]
-    [(_ [(dom ...) rng : eff1 eff2] ...)
-     (make-Function (list (make-arr* (list dom ...) rng #f eff1 eff2) ...))]
-    [(_ [(dom ...) rng rst : eff1 eff2] ...)
-     (make-Function (list (make-arr* (list dom ...) rng rst eff1 eff2) ...))]))
-(define (cl->* . args)
-  (define (funty-arities f)
-    (match f
-      [(Function: as) as]))
-  (make-Function (apply append (map funty-arities args))))
+(define (-Tuple l)
+  (foldr -pair (-val '()) l))
 
-(define-syntax (->key stx)
-  (syntax-parse stx
-                [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
-                 #'(make-Function
-                    (list
-                     (make-arr* (list ty ...)
-                                rng
-                                #f
-                                #f
-                                (list (make-Keyword 'k kty opt) ...)
-                                null
-                                null)))]))
+(define (untuple t)
+  (match t
+    [(Value: '()) null]
+    [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
+                       [else #f])]
+    [_ #f]))
 
-(define make-arr*
-  (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))]
-               [(dom rng rest) (make-arr dom rng rest #f null (list) (list))]
-               [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)]
-               [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]
-               [(dom rng rest drest kws eff1 eff2)
-                (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword<?) eff1 eff2)]))
 
-(define (make-arr-dots dom rng dty dbound)
-  (make-arr* dom rng #f (cons dty dbound) null null))
+(d/c (-result t [f -no-lfilter] [o -no-lobj])
+  (c:->* (Type/c) (LFilterSet? LatentObject?) Result?)
+  (make-Result t f o))
+
+;; basic types
 
 (define make-promise-ty
   (let ([s (string->uninterned-symbol "Promise")])
     (lambda (t)
       (make-Struct s #f (list t) #f #f #'promise? values))))
 
+(define -Listof (-poly (list-elem) (make-Listof list-elem)))
+
+
 (define N (make-Base 'Number #'number?))
 (define -Integer (make-Base 'Integer #'exact-integer?))
 (define B (make-Base 'Boolean #'boolean?))
@@ -139,6 +92,35 @@
 
 (define -Nat -Integer)
 
+(define Any-Syntax
+  (-mu x
+       (-Syntax (*Un 
+                 N
+                 B
+                 Sym
+                 -String
+		 -Keyword                 
+                 (-mu y (*Un (-val '()) (-pair x (*Un x y))))
+                 (make-Vector x)
+                 (make-Box x)))))
+
+(define Ident (-Syntax Sym))
+
+(define -Sexp (-mu x (*Un (-val null) N B Sym -String (-pair x x))))
+(define -Port (*Un -Output-Port -Input-Port))
+
+(define -Pathlike (*Un -String -Path))
+(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same)))
+(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String))
+(define -Byte N)
+
+(define -no-lfilter (make-LFilterSet null null))
+(define -no-filter (make-FilterSet null null))
+(define -no-lobj (make-LEmpty))
+(define -no-obj (make-Empty))
+
+;; convenient syntax
+
 (define-syntax -v 
   (syntax-rules ()
     [(_ x) (make-F 'x)]))
@@ -162,71 +144,76 @@
      (let ([var (-v var)])
        (make-Mu 'var ty))]))
 
+;; function type constructors
 
-(define -values make-Values)
+(define top-func (make-Function (list (make-top-arr))))
 
-(define-syntax *Un
-  (syntax-rules ()
-    [(_ . args) (make-Union (list . args))]))
+(d/c (make-arr* dom rng
+                #:rest [rest #f] #:drest [drest #f] #:kws [kws null]
+                #:filters [filters -no-lfilter] #:object [obj -no-lobj])
+  (c:->* ((listof Type/c) Type/c)
+         (#:rest Type/c 
+          #:drest (cons/c symbol? Type/c)
+          #:kws (listof Keyword?)
+          #:filters LFilterSet?
+          #:object LatentObject?)
+         arr?)
+  (make-arr dom (-result rng filters obj) rest drest (sort #:key Keyword-kw kws keyword<?)))
 
+(define-syntax ->*
+  (syntax-rules (:)
+    [(_ dom rng)       
+     (make-Function (list (make-arr* dom rng)))]
+    [(_ dom rst rng)
+     (make-Function (list (make-arr* dom rng #:rest rst)))]
+    [(_ dom rng : filters)
+     (make-Function (list (make-arr* dom rng #f #:filters filters)))]
+    [(_ dom rst rng : filters)
+     (make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))]))
 
-(define -pair make-Pair)
+(define-syntax (-> stx)
+  (syntax-parse stx
+    #:literals (:)
+    [(_ dom ... rng : filters)
+     #'(->* (list dom ...) rng : filters)]
+    [(_ dom ... rng : filters)
+     #'(->* (list dom ...) rng : filters)]
+    [(_ dom ... rng)
+     #'(->* (list dom ...) rng)]))
 
-(define -struct make-Struct)
-(define -val make-Value)
+(define-syntax ->...
+  (syntax-rules (:)
+    [(_ dom rng)
+     (->* dom rng)]
+    [(_ dom (dty dbound) rng)
+     (make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound))))]
+    [(_ dom rng : filters)
+     (->* dom rng : filters)]
+    [(_ dom (dty dbound) rng : filters)
+     (make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))]))
 
-(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
-(define -Listof (-poly (list-elem) (make-Listof list-elem)))
+(define (cl->* . args)
+  (define (funty-arities f)
+    (match f
+      [(Function: as) as]))
+  (make-Function (apply append (map funty-arities args))))
 
-(define -lst make-Listof)
-(define -Sexp (-mu x (*Un N B Sym -String (-val null) (-pair x x))))
-(define -Port (*Un -Output-Port -Input-Port))
+(define-syntax (->key stx)  
+  (syntax-parse stx
+                [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
+                 #'(make-Function
+                    (list
+                     (make-arr* (list ty ...)
+                                rng
+                                #:kws (list (make-Keyword 'k kty opt) ...))))]))
 
-(define (-lst* #:tail [tail (-val null)] . args)
-  (if (null? args)
-      tail
-      (-pair (car args) (apply -lst* #:tail tail (cdr args)))))
+(define (make-arr-dots dom rng dty dbound)
+  (make-arr* dom rng #:drest (cons dty dbound)))
 
 
-#;(define NE (-mu x (Un N (make-Listof x))))
-(define -NE (-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null)))))))
-
-(define -Param make-Param)
-
 (define make-pred-ty
   (case-lambda 
     [(in out t)
-     (->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))]
+     (->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))]
     [(t) (make-pred-ty (list Univ) B t)]))
 
-(define -Pathlike (*Un -String -Path))
-(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same)))
-(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String))
-(define -Byte N)
-
-(define (-Tuple l)
-  (foldr -pair (-val '()) l))
-
-(define (untuple t)
-  (match t
-    [(Value: '()) null]
-    [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
-                       [else #f])]
-    [_ #f]))
-
-(define -box make-Box)
-(define -vec make-Vector)
-
-(define Any-Syntax ;(-Syntax Univ)
-  (-mu x
-       (-Syntax (*Un 
-                 N
-                 B
-                 Sym
-                 -String
-		 -Keyword                 
-                 (-mu y (*Un (-val '()) (-pair x (*Un x y))))
-                 (make-Vector x)
-                 (make-Box x)))))
-
-(define Ident (-Syntax Sym))
\ No newline at end of file
diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss
index 68b393b8d8..83551c46b2 100644
--- a/collects/typed-scheme/rep/interning.ss
+++ b/collects/typed-scheme/rep/interning.ss
@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require syntax/boundmap (for-syntax scheme/base stxclass)
-         macro-debugger/stepper)
+         #;macro-debugger/stepper)
 
 (provide defintern hash-id)
 
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index ebad2a3324..3de0e278e8 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -170,16 +170,16 @@
        (k:keyword #:matcher mtch pats ... e:expr)
        #:with kw #'k.datum
        #:with val (list #'mtch 
-                        (syntax #;#;/loc (current-syntax-context) (pats ...))
+                        (syntax/loc this-syntax (pats ...))
                         (lambda () #'e)
-                        #'here #;(current-syntax-context)))
+                        this-syntax))
       (pattern
        (k:keyword pats ... e:expr) 
        #:with kw (syntax-e #'k)
        #:with val (list (mk-matcher #'kw) 
-                        (syntax #;#;/loc (current-syntax-context) (pats ...))
+                        (syntax/loc this-syntax (pats ...))
                         (lambda () #'e)
-                        #'here #;(current-syntax-context))))
+                        this-syntax)))
     (define (gen-clause k v)
       (match v
         [(list match-ex pats body-f src)
@@ -210,12 +210,7 @@
                         (for/list ([rec-id rec-ids]
                                    [k kws])
                           #`[#,rec-id #,(hash-ref (attribute recs.mapping) k
-                                                  #'values
-                                                  #;
-                                                  (lambda ()                                                    
-                                                    (error (format
-                                                            "failed to find key ~a in table ~a"
-                                                            k (attribute recs.mapping)))))])])
+                                                  #'values)])])
            #`(let (let-clauses ...
                    [#,fold-target ty])
                ;; then generate the fold
diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss
index fdf2202fc0..b8e5f21f9b 100644
--- a/collects/typed-scheme/utils/utils.ss
+++ b/collects/typed-scheme/utils/utils.ss
@@ -164,7 +164,7 @@
       [(_ val)
        #'(? (lambda (x) (equal? val x)))])))
 
-(define-for-syntax printing? #t)
+(define-for-syntax printing? #f)
 
 (define-syntax-rule (defprinter t ...)
   (begin
@@ -241,7 +241,7 @@
   (append t (build-list (- (length s) (length t)) (lambda _ extra))))
 
 (define-for-syntax enable-contracts? #t)
-(provide (for-syntax enable-contracts?) p/c w/c cnt)
+(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
 
 (define-syntax p/c
   (if enable-contracts?
@@ -265,6 +265,21 @@
           [(_ name specs . body)
            #'(begin . body)]))))
 
+(define-syntax d/c
+  (if enable-contracts?
+      (make-rename-transformer #'define/contract)
+      (lambda (stx)        
+        (syntax-parse stx
+          [(_ head cnt . body)
+           #'(define head . body)]))))
+
+(define-syntax d-s/c
+  (if enable-contracts?
+      (make-rename-transformer #'define-struct/contract)
+      (syntax-rules ()
+        [(_ hd ([i c] ...) . opts)
+         (define-struct hd (i ...) . opts)])))
+
 (define-signature-form (cnt stx)
   (syntax-case stx ()
     [(_ nm cnt)