From cbcad0528c45427ebdd45350068a254e000ed159 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Sat, 14 Feb 2009 21:32:02 +0000
Subject: [PATCH] There is now a new form, define-unit/contract, that basically
 mixes define-unit with the application of a unit contract.  So you can think
 of it as a define/contract for units that keeps the static info needed for
 link inference.

svn: r13584
---
 collects/mzlib/private/unit-compiletime.ss    | 17 ++--
 .../mzlib/private/unit-contract-syntax.ss     | 57 ++++++++---
 collects/mzlib/private/unit-contract.ss       | 32 +++---
 collects/mzlib/unit.ss                        | 97 ++++++++++++++-----
 collects/scribblings/guide/unit.scrbl         | 92 ++++++------------
 collects/scribblings/reference/units.scrbl    | 18 +++-
 collects/tests/units/test-unit-contracts.ss   | 48 ++++++++-
 7 files changed, 236 insertions(+), 125 deletions(-)

diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss
index 49ad4d8b49..b8eede078a 100644
--- a/collects/mzlib/private/unit-compiletime.ss
+++ b/collects/mzlib/private/unit-compiletime.ss
@@ -111,16 +111,21 @@
       (parameterize ((error-syntax stx))
         (raise-stx-err "illegal use of signature form"))))
     
-  ;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier)
-  (define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder)
+  ;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier boolean)
+  (define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder contracted?)
     (lambda (struct stx) 
       (with-syntax ((u (unit-info-unit-id struct)))
         (syntax-case stx (set!)
           ((set! x y)
-           #`(begin 
-               #,(syntax/loc #'y (check-unit y 'set!))
-               #,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!))
-               (set! u y)))
+           (if (unit-info-contracted? struct)
+               (raise-syntax-error 'set!
+                                   "cannot set! a contracted unit"
+                                   stx
+                                   (syntax x))
+               #`(begin 
+                   #,(syntax/loc #'y (check-unit y 'set!))
+                   #,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!))
+                   (set! u y))))
           ((_ . y)
            (syntax/loc stx (u . y)))
           (x
diff --git a/collects/mzlib/private/unit-contract-syntax.ss b/collects/mzlib/private/unit-contract-syntax.ss
index 8f6fa734f5..97a6af6659 100644
--- a/collects/mzlib/private/unit-contract-syntax.ss
+++ b/collects/mzlib/private/unit-contract-syntax.ss
@@ -4,7 +4,8 @@
          "unit-compiletime.ss"
          (for-template "unit-keywords.ss"))
 
-(provide import-clause export-clause)
+(provide import-clause/contract export-clause/contract dep-clause
+         import-clause/c export-clause/c)
 
 (define-syntax-class sig-id
   #:attributes ()
@@ -14,29 +15,55 @@
                                     (signature? (set!-trans-extract x))))))
 
 (define-syntax-class sig-spec #:literals (prefix rename only except)
+  #:attributes ((name 0))
+  #:transparent
+  (pattern name:sig-id)
+  (pattern (prefix i:identifier s:sig-spec)
+           #:with name #'s.name)
+  (pattern (rename s:sig-spec [int:identifier ext:identifier] ...)
+           #:with name #'s.name)
+  (pattern (only s:sig-spec i:identifier ...)
+           #:with name #'s.name)
+  (pattern (except s:sig-spec i:identifier ...)
+           #:with name #'s.name))
+
+(define-syntax-class tagged-sig-spec #:literals (tag)
+  #:transparent
+  (pattern s:sig-spec
+           #:with i #f)
+  (pattern (tag i:identifier s:sig-spec)))
+
+(define-syntax-class tagged-sig-id #:literals (tag)
   #:attributes ()
   #:transparent
   (pattern s:sig-id)
-  (pattern (prefix i:identifier s:sig-spec))
-  (pattern (rename s:sig-spec [int:identifier ext:identifier] ...))
-  (pattern (only s:sig-spec i:identifier ...))
-  (pattern (except s:sig-spec i:identifier ...)))
-
-(define-syntax-class tagged-sig-spec #:literals (tag)
-  #:attributes ()
-  #:transparent
-  (pattern s:sig-spec)
-  (pattern (tag i:identifier s:sig-spec)))
+  (pattern (tag i:identifier s:sig-id)))
 
 (define-syntax-class unit/c-clause
+  #:transparent
+  (pattern (s:tagged-sig-id [x:identifier c:expr] ...))
+  (pattern s:tagged-sig-id ;; allow a non-wrapped sig, which is the same as (sig)
+           #:with (x ...) null
+           #:with (c ...) null))
+(define-syntax-class import-clause/c #:literals (import)
+  #:transparent
+  (pattern (import i:unit/c-clause ...)))
+(define-syntax-class export-clause/c #:literals (export)
+  #:transparent
+  (pattern (export e:unit/c-clause ...)))
+
+(define-syntax-class unit/contract-clause
   #:transparent
   (pattern (s:tagged-sig-spec [x:identifier c:expr] ...))
   (pattern s:tagged-sig-spec ;; allow a non-wrapped sig, which is the same as (sig)
            #:with (x ...) null
            #:with (c ...) null))
-(define-syntax-class import-clause #:literals (import)
+(define-syntax-class import-clause/contract #:literals (import)
   #:transparent
-  (pattern (import i:unit/c-clause ...)))
-(define-syntax-class export-clause #:literals (export)
+  (pattern (import i:unit/contract-clause ...)))
+(define-syntax-class export-clause/contract #:literals (export)
   #:transparent
-  (pattern (export e:unit/c-clause ...)))
\ No newline at end of file
+  (pattern (export e:unit/contract-clause ...)))
+(define-syntax-class dep-clause #:literals (init-depend)
+  #:transparent
+  (pattern (init-depend s:tagged-sig-id ...)))
\ No newline at end of file
diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss
index 861ddfba68..9becfce29f 100644
--- a/collects/mzlib/private/unit-contract.ss
+++ b/collects/mzlib/private/unit-contract.ss
@@ -4,12 +4,13 @@
                      stxclass
                      syntax/boundmap
                      "unit-compiletime.ss"
-                     "unit-contract-syntax.ss")
+                     "unit-contract-syntax.ss"
+                     "unit-syntax.ss")
          scheme/contract
          "unit-utils.ss"
          "unit-runtime.ss")
 
-(provide unit/c)
+(provide (for-syntax unit/c/core) unit/c)
 
 (define-for-syntax (contract-imports/exports import?)
   (λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
@@ -78,9 +79,9 @@
 (define-for-syntax contract-imports (contract-imports/exports #t))
 (define-for-syntax contract-exports (contract-imports/exports #f))
 
-(define-syntax/err-param (unit/c stx)
+(define-for-syntax (unit/c/core stx)
   (syntax-parse stx
-    [(_ :import-clause :export-clause)
+    [(:import-clause/c :export-clause/c)
      (begin
        (define-values (isig tagged-import-sigs import-tagged-infos 
                             import-tagged-sigids import-sigs)
@@ -97,17 +98,15 @@
          (define xs-list (syntax->list xs))
          (let ([dup (check-duplicate-identifier xs-list)])
            (when dup
-             (raise-syntax-error 'unit/c
-                                 (format "duplicate identifier found for signature ~a"
-                                         (syntax->datum name))
-                                 dup)))
+             (raise-stx-err (format "duplicate identifier found for signature ~a"
+                                    (syntax->datum name))
+                            dup)))
          (let ([ids (map car (car sig))])
            (for-each (λ (id)
                        (unless (memf (λ (i) (bound-identifier=? id i)) ids)
-                         (raise-syntax-error 'unit/c
-                                             (format "identifier not member of signature ~a" 
-                                                     (syntax-e name))
-                                             id)))
+                         (raise-stx-err (format "identifier not member of signature ~a" 
+                                                (syntax-e name))
+                                        id)))
                      xs-list))
          (for ([x (in-list xs-list)]
                [c (in-list (syntax->list cs))])
@@ -130,7 +129,9 @@
                  (syntax->list #'((e.x ...) ...))
                  (syntax->list #'((e.c ...) ...)))
        
-       (with-syntax ([((import-key ...) ...)
+       (with-syntax ([(isig ...) isig]
+                     [(esig ...) esig]
+                     [((import-key ...) ...)
                       (map tagged-info->keys import-tagged-infos)]
                      [((export-key ...) ...)
                       (map tagged-info->keys export-tagged-infos)]
@@ -210,6 +211,11 @@
                         (list #f "not-used") 'not-used null))
                      #t)))))))]))
 
+(define-syntax/err-param (unit/c stx)
+  (syntax-case stx ()
+    [(_ . sstx)
+     (unit/c/core #'sstx)]))
+
 (define (contract-check-helper sub-sig super-sig import? val src-info blame ctc)
   (define t (make-hash))
   (let loop ([i (sub1 (vector-length sub-sig))])
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 3c1720252a..1748b4e1db 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -1,11 +1,13 @@
 (module unit mzscheme
   (require-for-syntax mzlib/list
+                      stxclass
                       syntax/boundmap
                       syntax/context
                       syntax/kerncase
                       syntax/name
                       syntax/struct
                       syntax/stx
+                      "private/unit-contract-syntax.ss"
                       "private/unit-compiletime.ss"
                       "private/unit-syntax.ss")
   
@@ -20,14 +22,15 @@
   (provide define-signature-form struct open
            define-signature provide-signature-elements
            only except rename import export prefix link tag init-depend extends contracted
-           unit? (all-from "private/unit-contract.ss")
+           unit?
            (rename :unit unit) define-unit 
            compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
            invoke-unit define-values/invoke-unit
            invoke-unit/infer define-values/invoke-unit/infer
            unit-from-context define-unit-from-context
            define-unit-binding
-           unit/new-import-export define-unit/new-import-export)
+           unit/new-import-export define-unit/new-import-export
+           unit/c define-unit/contract)
  
   (define-syntax/err-param (define-signature-form stx)
     (syntax-case stx ()
@@ -1264,32 +1267,38 @@
 
   
   
+  (define-for-syntax (build-define-unit-helper contracted?)
+    (lambda (stx build err-msg)
+      (syntax-case stx ()
+        ((_ name . rest)
+         (begin
+           (check-id #'name)
+           (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
+                                       (build #'rest ))))
+             (with-syntax ((((itag . isig) ...) i)
+                           (((etag . esig) ...) e)
+                           (((deptag . depsig) ...) d)
+                           (contracted? contracted?))
+               (quasisyntax/loc (error-syntax)
+                 (begin
+                   (define u #,exp)
+                   (define-syntax name
+                     (make-set!-transformer
+                      (make-unit-info ((syntax-local-certifier) (quote-syntax u))
+                                      (list (cons 'itag (quote-syntax isig)) ...)
+                                      (list (cons 'etag (quote-syntax esig)) ...)
+                                      (list (cons 'deptag (quote-syntax deptag)) ...)
+                                      (quote-syntax name)
+                                      contracted?)))))))))
+        ((_)
+         (raise-stx-err err-msg)))))
+  
   ;; build-define-unit : syntax-object
   ;;                     (syntax-object -> (values syntax-object (listof identifier) (listof identifier))
   ;;                     string ->
   ;;                     syntax-object
-  (define-for-syntax (build-define-unit stx build err-msg)
-    (syntax-case stx ()
-      ((_ name . rest)
-       (begin
-         (check-id #'name)
-         (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
-                                     (build #'rest ))))
-           (with-syntax ((((itag . isig) ...) i)
-                         (((etag . esig) ...) e)
-                         (((deptag . depsig) ...) d))
-             (quasisyntax/loc (error-syntax)
-               (begin
-                 (define u #,exp)
-                 (define-syntax name
-                   (make-set!-transformer
-                    (make-unit-info ((syntax-local-certifier) (quote-syntax u))
-                                    (list (cons 'itag (quote-syntax isig)) ...)
-                                    (list (cons 'etag (quote-syntax esig)) ...)
-                                    (list (cons 'deptag (quote-syntax deptag)) ...)
-                                    (quote-syntax name))))))))))
-      ((_)
-       (raise-stx-err err-msg))))
+  (define-for-syntax build-define-unit (build-define-unit-helper #f))
+  (define-for-syntax build-define-unit/contracted (build-define-unit-helper #t))
 
   (define-for-syntax (build-define-unit-binding stx)
     
@@ -1360,6 +1369,46 @@
                              (check-ufc-syntax sig)
                              (build-unit-from-context sig))
       "missing unit name and signature"))
+  
+  (define-for-syntax (build-unit/contract stx)
+    (syntax-parse stx
+      [(:import-clause/contract :export-clause/contract dep:dep-clause . body)
+       (let-values ([(exp isigs esigs deps) 
+                     (build-unit
+                      (check-unit-syntax
+                       (syntax/loc stx
+                         ((import i.s ...) (export e.s ...) dep . body))))])
+         (with-syntax ([(import-tagged-sig-id ...)
+                        (map (λ (i s)
+                               (if (identifier? i) #`(tag #,i #,s) s))
+                             (syntax->list #'(i.s.i ...))
+                             (syntax->list #'(i.s.s.name ...)))]
+                       [(export-tagged-sig-id ...)
+                        (map (λ (i s)
+                               (if (identifier? i) #`(tag #,i #,s) s))
+                             (syntax->list #'(e.s.i ...))
+                             (syntax->list #'(e.s.s.name ...)))])
+           (with-syntax ([name (syntax-local-infer-name (error-syntax))]
+                         [new-unit exp]
+                         [unit-contract
+                          (unit/c/core
+                           (syntax/loc stx
+                             ((import (import-tagged-sig-id [i.x i.c] ...) ...)
+                              (export (export-tagged-sig-id [e.x e.c] ...) ...))))]
+                         [src-info (id->contract-src-info #'name)])
+             (values 
+              (syntax/loc stx
+                (contract unit-contract new-unit '(unit name) (current-contract-region) src-info))
+              isigs esigs deps))))]
+      [(ic:import-clause/contract ec:export-clause/contract . body)
+       (build-unit/contract 
+        (syntax/loc stx
+          (ic ec (init-depend) . body)))]))
+  
+  (define-syntax/err-param (define-unit/contract stx)
+    (build-define-unit/contracted stx (λ (stx)
+                                        (build-unit/contract stx))
+     "missing unit name"))
 
   (define-for-syntax (unprocess-tagged-id ti)
     (if (car ti)
diff --git a/collects/scribblings/guide/unit.scrbl b/collects/scribblings/guide/unit.scrbl
index 723b02fae1..e19dec8598 100644
--- a/collects/scribblings/guide/unit.scrbl
+++ b/collects/scribblings/guide/unit.scrbl
@@ -530,85 +530,49 @@ causes the appropriate contract errors.
 
 However, sometimes we may have a unit that must conform to an
 already existing signature that is not contracted.  In this case,
-we can use the @scheme[unit/c] contract combinator, which creates
-a new unit that protects parts of the wrapped unit as desired.
+we can create a unit contract with @scheme[unit/c] or use
+the @scheme[define-unit/contract] form, which defines a unit which
+has been wrapped with a unit contract.
 
-For example, here's a version of @scheme[toy-store@] which has a
-slightly buggy implementation of the uncontracted @scheme[toy-store^]
-signature.  When we provide the new @scheme[wrapped-toy-store@] unit,
-we protect its exports.
+For example, here's a version of @scheme[toy-factory@] which still
+implements the regular @scheme[toy-factory^], but whose exports
+have been protected with an appropriate unit contract.
 
 @schememod/eval[[#:file
-"wrapped-toy-store-unit.ss"
+"wrapped-simple-factory-unit.ss"
 scheme
 
-(require "toy-store-sig.ss"
-         "toy-factory-sig.ss")]
+(require "toy-factory-sig.ss")]
 
-(define-unit wrapped-toy-store@
-  (import toy-factory^)
-  (export toy-store^)
+(define-unit/contract wrapped-simple-factory@
+  (import)
+  (export (toy-factory^
+           [build-toys (-> integer? (listof toy?))]
+           [repaint    (-> toy? symbol? toy?)]
+           [toy?       (-> any/c boolean?)]
+           [toy-color  (-> toy? symbol?)]))
 
-  (define inventory null)
+  (printf "Factory started.\n")
 
-  (define (store-color) 3) (code:comment #, @t{Not a valid color!})
+  (define-struct toy (color) #:transparent)
 
-  (define (maybe-repaint t)
-    (if (eq? (toy-color t) (store-color))
-        t
-        (repaint t (store-color))))
+  (define (build-toys n)
+    (for/list ([i (in-range n)])
+      (make-toy 'blue)))
 
-  (define (stock! n)
-    (set! inventory 
-          (append inventory
-                  (map maybe-repaint
-                       (build-toys n)))))
+  (define (repaint t col)
+    (make-toy col)))
 
-  (define (get-inventory) inventory))
-
-(provide/contract
- [wrapped-toy-store@ 
-  (unit/c (import toy-factory^)
-          (export (toy-store^
-                   [store-color (-> symbol?)]
-                   [stock! (-> integer? void?)]
-                   [get-inventory (-> (listof toy?))])))])
+(provide contracted-simple-factory@)
 ]
 
-Since the result of the @scheme[unit/c] combinator is a new unit value
-which has not been defined with @scheme[define-unit] or another similar
-form, we run into problems with signature inference.  The section 
-@secref{firstclassunits} lists options that we can use to handle the
-resulting values.
-
 @interaction[
 #:eval toy-eval
-(eval:alts (require "wrapped-toy-store-unit.ss")
-           (define wrapped-toy-store@
-             (contract (unit/c (import toy-factory^)
-                               (export (toy-store^
-                                        [store-color (-> symbol?)]
-                                        [stock! (-> integer? void?)]
-                                        [get-inventory (-> (listof toy?))])))
-                       wrapped-toy-store@
-                       'wrapped-toy-store-unit
-                       'top-level
-                       (list (make-srcloc 'top-level #f #f #f #f) "wrapped-toy-store@"))))
-(define-unit-binding protected-toy-store@
-  wrapped-toy-store@
-  (import toy-factory^)
-  (export toy-store^))
-(define-compound-unit/infer checked-toy-store+factory@
-  (import)
-  (export toy-factory^ toy-store^)
-  (link store-specific-factory@ protected-toy-store@))
-(define-values/invoke-unit/infer checked-toy-store+factory@)
-(store-color)
-(stock! 'a)
-(code:comment #, @t{This fails because of the factory's (store-color) call})
-(stock! 4) 
-(code:comment #, @t{Since it failed, there's no inventory})
-(get-inventory)
+(eval:alts (require "wrapped-simple-factory-unit.ss") (void))
+(define-values/invoke-unit/infer wrapped-simple-factory@)
+(build-toys 3)
+(build-toys #f)
+(repaint 3 'blue)
 ]
 
 
diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl
index 2d3e585712..5ff110a198 100644
--- a/collects/scribblings/reference/units.scrbl
+++ b/collects/scribblings/reference/units.scrbl
@@ -635,8 +635,8 @@ Expands to a @scheme[provide] of all identifiers implied by the
 
 @defform/subs[#:literals (import export)
               (unit/c (import sig-block ...) (export sig-block ...))
-              ([sig-block (tagged-sig-spec [id contract] ...)
-                          tagged-sig-spec])]{
+              ([sig-block (tagged-sig-id [id contract] ...)
+                          tagged-sig-id])]{
 
 A @deftech{unit contract} wraps a unit and checks both its imported and
 exported identifiers to ensure that they match the appropriate contracts.
@@ -649,6 +649,20 @@ identifier which is not listed for a given signature is left alone.
 Variables used in a given @scheme[contract] expression first refer to other
 variables in the same signature, and then to the context of the 
 @scheme[unit/c] expression.}
+                                          
+@defform/subs[#:literals (import export)
+              (define-unit/contract unit-id
+                (import sig-spec-block ...)
+                (export sig-spec-block ...)
+                init-depends-decl
+                unit-body-expr-or-defn
+                ...)
+              ([sig-spec-block (tagged-sig-spec [id contract] ...)
+                               tagged-sig-spec])]{
+The @scheme[define-unit/contract] form defines an unit compatible with
+link inference whose imports and exports are contracted with a unit
+contract.  The unit name is used for the positive blame of the contract.}
+
 
 @; ------------------------------------------------------------------------
 
diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss
index 360ed179bf..b1b89c32fb 100644
--- a/collects/tests/units/test-unit-contracts.ss
+++ b/collects/tests/units/test-unit-contracts.ss
@@ -717,4 +717,50 @@
   
   (f 0)
   (test-runtime-error exn:fail:contract? "V@ broke contract on f"
-    (f 3)))
\ No newline at end of file
+    (f 3)))
+
+(let ()
+  (define-signature foo^ (x y))
+  (define-unit/contract U@
+    (import)
+    (export (foo^ [x (-> number? number?)]))
+    (define (x n) (zero? n))
+    (define y 4))
+  (define-unit V@
+    (import foo^)
+    (export)
+    (x 4))
+  (define-compound-unit/infer W@
+    (import) (export) (link U@ V@))
+  (define-values/invoke-unit/infer U@)
+  y
+  (test-runtime-error exn:fail:contract? "top-level broke contract on x"
+    (x #t))
+  (test-runtime-error exn:fail:contract? "U@ broke contract on x"
+    (x 3))
+  (test-runtime-error exn:fail:contract? "U@ broke contract on x"
+    (invoke-unit W@)))
+
+(let ()
+  (define-signature foo^ (x? f))
+  (define-unit/contract U@
+    (import)
+    (export (foo^ [f (-> x? number?)]))
+    (define (x? n) (or (= n 3)
+                       (zero? n)))
+    (define (f n) (if (= n 3) #t n)))
+  (define-unit V@
+    (import foo^)
+    (export)
+    (test-runtime-error exn:fail:contract? "top-level broke contract on x"
+      (f 2))
+    (test-runtime-error exn:fail:contract? "U@ broke contract on x"
+      (f 3)))
+  (define-compound-unit/infer W@
+    (import) (export) (link U@ V@))
+  (define-values/invoke-unit/infer U@)
+  (test-runtime-error exn:fail:contract? "top-level broke contract on x"
+    (f 4))
+  (test-runtime-error exn:fail:contract? "U@ broke contract on x"
+    (f 3))
+  (invoke-unit W@))