From 2183983a1bbde6daa99b68ce94dbd70b4918f381 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 17 Feb 2009 17:30:30 +0000
Subject: [PATCH] Move contract-enabling code to utils/utils Move `cnt'
 signature form to utils/utils, controlled by same boolean. Use `w/c' and
 `p/c' to enable/disable contracts in dt/de. Contract for `ret'.

svn: r13699

original commit: 00ff608247134f49ffecae576c90df40dacf7143
---
 collects/typed-scheme/private/type-utils.ss | 18 ++++++-----
 collects/typed-scheme/rep/rep-utils.ss      |  6 ++--
 collects/typed-scheme/utils/utils.ss        | 35 ++++++++++++++++++++-
 3 files changed, 47 insertions(+), 12 deletions(-)

diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss
index 0617aa0f..d4ca2ad0 100644
--- a/collects/typed-scheme/private/type-utils.ss
+++ b/collects/typed-scheme/private/type-utils.ss
@@ -8,7 +8,8 @@
          scheme/match
          scheme/list
          mzlib/trace
-         (for-syntax scheme/base))
+         scheme/contract
+         (for-syntax scheme/base stxclass))
 
 (provide fv fv/list
          substitute
@@ -16,7 +17,7 @@
          substitute-dotted
          subst-all
          subst 
-         ret
+         ;ret
          instantiate-poly
          instantiate-poly-dotted
          tc-result:
@@ -172,19 +173,22 @@
 
 
 ;; this structure represents the result of typechecking an expression
-(define-struct tc-result (t thn els) #:inspector #f)
+(define-struct tc-result (t thn els) #:transparent)
 
 (define-match-expander tc-result:
-  (lambda (stx)
-    (syntax-case stx ()
-      [(form pt) #'(struct tc-result (pt _ _))]
-      [(form pt pe1 pe2) #'(struct tc-result (pt pe1 pe2))])))
+  (syntax-parser 
+   [(_ pt) #'(struct tc-result (pt _ _))]
+   [(_ pt pe1 pe2) #'(struct tc-result (pt pe1 pe2))]))
 
 ;; convenience function for returning the result of typechecking an expression
 (define ret
   (case-lambda [(t) (make-tc-result t (list) (list))]
                [(t thn els) (make-tc-result t thn els)]))
 
+(p/c
+ [ret (case-> (-> Type? tc-result?)
+              (-> Type? (listof Effect?) (listof Effect?) tc-result?))])
+
 (define (subst v t e) (substitute t v e))
 
 
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index f0a4b87c..caaa0daa 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -41,8 +41,6 @@
 (define-for-syntax effect-rec-id #'effect-rec-id)
 (define-for-syntax fold-target #'fold-target)
 
-(define-for-syntax enable-contracts? #t)
-
 (provide (for-syntax type-rec-id effect-rec-id fold-target))
 
 (define-syntaxes (dt de)
@@ -106,7 +104,7 @@
 			    #'(begin)                                 
 			    #`(begin 
 				(provide ex pred acc ...)
-				(provide/contract (rename *maker maker *maker-cnt))))]
+				(p/c (rename *maker maker *maker-cnt))))]
 	      [intern 
 	       (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))])
 		 (syntax-parse #'flds.fs
@@ -121,7 +119,7 @@
                                           (list (combiner #'free-vars* #'flds.fs)
                                                 (combiner #'free-idxs* #'flds.fs)))])
                  (quasisyntax/loc stx
-                   (with-contract nm ([*maker *maker-cnt])
+                   (w/c nm ([*maker *maker-cnt])
                      (define (*maker . flds.fs)
                        (define v (**maker . flds.fs))
                        (unless-in-table 
diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss
index 485bc20b..c386b0c2 100644
--- a/collects/typed-scheme/utils/utils.ss
+++ b/collects/typed-scheme/utils/utils.ss
@@ -1,9 +1,11 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base)
+(require (for-syntax scheme/base stxclass)
+         scheme/contract
          mzlib/plt-match
 	 scheme/require-syntax
          mzlib/struct
+         scheme/unit
          (except-in stxclass id))
 
 (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
@@ -235,3 +237,34 @@
 (define (extend s t extra)
   (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)
+
+(define-syntax p/c
+  (if enable-contracts?
+      (make-rename-transformer #'provide/contract)
+      (lambda (stx)
+        (define-syntax-class clause
+          #:literals (rename)
+          #:attributes (i)
+          (pattern [rename out:id in:id]
+                   #:with i #'(rename-out out in))
+          (pattern [i:id c]))
+        (syntax-parse stx
+          [(_ c:clause ...)
+           #'(provide c.i ...)]))))
+
+(define-syntax w/c
+  (if enable-contracts?
+      (make-rename-transformer #'with-contract)
+      (lambda (stx)        
+        (syntax-parse stx
+          [(_ name specs . body)
+           #'(begin . body)]))))
+
+(define-signature-form (cnt stx)
+  (syntax-case stx ()
+    [(_ nm cnt)
+     (if enable-contracts?
+         (list #'[contracted (nm cnt)])     
+         (list #'nm))]))
\ No newline at end of file