Sam and I did some work to allow automatic inferred linking in

(define-values/)invoke-unit/infer.

svn: r14315

collects/framework/main.ss

@@ -49,13 +49,10 @@
  (prefix scheme: framework:scheme-class^)
  (prefix main: framework:main-class^))
 
-(define-compound-unit/infer framework+mred@
+(define-values/invoke-unit/infer
-  (import)
   (export framework^)
   (link standard-mred@ framework@))
 
-(define-values/invoke-unit/infer framework+mred@)
-
 (provide/doc
  (parameter-doc
   text:autocomplete-append-after

collects/graphics/graphics.ss

@@ -6,9 +6,6 @@
 	   "graphics-unit.ss")
   (provide-signature-elements graphics^ graphics:posn^)
 
-  (define-compound-unit/infer graphics+mred@
+  (define-values/invoke-unit/infer
-    (import)
     (export graphics^ graphics:posn^)
-    (link standard-mred@ graphics@))
+    (link standard-mred@ graphics@)))
-  
-  (define-values/invoke-unit/infer graphics+mred@))

collects/graphics/turtles.ss

@@ -1,15 +1,9 @@
 (module turtles mzscheme
   (require mzlib/unit
-	   mred/mred-sig
 	   mred/mred-unit
 	   "turtle-sig.ss"
 	   "turtle-unit.ss")
 
   (provide-signature-elements turtle^)
 
-  (define-compound-unit/infer turtle+mred@
+  (define-values/invoke-unit/infer (export turtle^) (link turtle@ standard-mred@)))
-    (import)
-    (export turtle^)
-    (link standard-mred@ turtle@))
-  
-  (define-values/invoke-unit/infer turtle+mred@))

collects/htdp/big-draw.ss

@@ -12,10 +12,9 @@
          graphics/graphics-sig
          graphics/graphics-posn-less-unit)
 
-(define-unit-from-context p@ graphics:posn^)
+(define-values/invoke-unit/infer
-(define-compound-unit/infer g@ (import) (export graphics^)
+  (export graphics^) 
-  (link standard-mred@ p@ graphics-posn-less@))
+  (link graphics-posn-less@ standard-mred@))
-(define-values/invoke-unit/infer g@)
 
 (provide-signature-elements graphics^)
 

collects/mzlib/unit.ss

@@ -1496,23 +1496,126 @@
         #`(tag #,(car ti) #,(cdr ti))
         (cdr ti)))
   
-  (define-syntax/err-param (define-values/invoke-unit/infer stx)
+  ;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax
-    (syntax-case stx ()
+  (define-for-syntax (build-invoke-unit/infer units define? exports)
-      ((_ u) 
+    (define (imps/exps-from-unit u)      
-       (let* ((ui (lookup-def-unit #'u))
+      (let* ([ui (lookup-def-unit u)]
-              (unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))])
+             [unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))])
                           (lambda (p)
-                             (unprocess-tagged-id (cons (car p) (i (cdr p))))))))
+                            (unprocess-tagged-id (cons (car p) (i (cdr p))))))]
-         (with-syntax (((sig ...) (map unprocess (unit-info-export-sig-ids ui)))
+             [isigs (map unprocess (unit-info-import-sig-ids ui))]
-                       ((isig ...) (map unprocess (unit-info-import-sig-ids ui))))
+             [esigs (map unprocess (unit-info-export-sig-ids ui))])
-           (quasisyntax/loc stx
+        (values isigs esigs)))
-             (define-values/invoke-unit u (import isig ...) (export sig ...))))))
+    (define (drop-from-other-list exp-tagged imp-tagged imp-sources)
-      ((_)
+      (let loop ([ts imp-tagged] [ss imp-sources])
-       (raise-stx-err "missing unit" stx))
+        (cond
-      ((_ . b)
+          [(null? ts) null]
+          [(ormap (lambda (tinfo2)
+                    (and (eq? (car (car ts)) (car tinfo2))
+                         (siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
+                  exp-tagged)
+           (loop (cdr ts) (cdr ss))]
+          [else (cons (car ss) (loop (cdr ts) (cdr ss)))])))
+    
+    (define (drop-duplicates tagged-siginfos sources)
+      (let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null])
+        (cond
+          [(null? ts) (values res-t res-s)]
+          [(ormap (lambda (tinfo2)
+                    (and (eq? (car (car ts)) (car tinfo2))
+                         (siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
+                  (cdr ts))
+           (loop (cdr ts) (cdr ss) res-t res-s)]
+          [else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))])))
+    
+    (define (imps/exps-from-units units exports)
+      (define-values (isigs esigs)
+        (let loop ([units units] [imps null] [exps null])
+          (if (null? units)
+              (values imps exps)
+              (let-values ([(i e) (imps/exps-from-unit (car units))])
+                (loop (cdr units) (append i imps) (append e exps))))))
+      (define-values (isig tagged-import-sigs import-tagged-infos 
+                           import-tagged-sigids import-sigs)
+        (process-unit-import (datum->syntax-object #f isigs)))
+      
+      (define-values (esig tagged-export-sigs export-tagged-infos 
+                           export-tagged-sigids export-sigs)
+        (process-unit-export (datum->syntax-object #f esigs)))
+      (check-duplicate-subs export-tagged-infos esig)
+      (let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)])
+        (values (drop-from-other-list export-tagged-infos itagged isources) 
+                (cond
+                 [(list? exports)
+                  (let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos 
+                                           spec-export-tagged-sigids spec-export-sigs)
+                                (process-unit-export (datum->syntax-object #f exports))])
+                    (restrict-exports export-tagged-infos
+                                      spec-esig spec-export-tagged-infos))]
+                 [else esig]))))
+        
+    (define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports)
+      (for-each (lambda (se ste)
+                  (unless (ormap (lambda (ute)
+                                   (and (eq? (car ute) (car ste))
+                                        (siginfo-subtype (cdr ute) (cdr ste))))
+                                 unit-tagged-exports)
+                          (raise-stx-err (format "no subunit exports signature ~a"
+                                                 (syntax-object->datum se))
+                                         se)))
+                spec-exports
+                spec-tagged-exports)
+      spec-exports)
+    (when (and (not define?) exports)
+          (error 'build-invoke-unit/infer 
+                 "internal error: exports for invoke-unit/infer"))
+    (when (null? units)
+      (raise-stx-err "no units in link clause"))
+    (cond [(identifier? units)
+           (let-values ([(isig esig) (imps/exps-from-units (list units) exports)])
+             (with-syntax ([u units]
+                           [(esig ...) esig]
+                           [(isig ...) isig])
+               (if define?
+                   (syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...)))
+                   (syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))]
+          [(list? units)
+           (let-values ([(isig esig) (imps/exps-from-units units exports)])
+             (with-syntax ([(new-unit) (generate-temporaries '(new-unit))]
+                           [(unit ...) units]
+                           [(esig ...) esig]
+                           [(isig ...) isig])
+               (with-syntax ([cunit (syntax/loc (error-syntax)
+                                      (define-compound-unit/infer new-unit
+                                        (import isig ...) (export esig ...) (link unit ...)))])
+                        
+                 (if define?
+                     (syntax/loc (error-syntax)
+                       (begin cunit
+                              (define-values/invoke-unit new-unit (import isig ...) (export esig ...))))
+                     (syntax/loc (error-syntax)
+                       (let ()
+                         cunit
+                         (invoke-unit new-unit (import isig ...))))))))]
+          ;; just for error handling
+          [else (lookup-def-unit units)]))
+
+  (define-syntax/err-param (define-values/invoke-unit/infer stx)
+    (syntax-case stx (export link)
+      [(_ (link unit ...))
+       (build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)]
+      [(_ (export e ...) (link unit ...))
+       (build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))]
+      [(_ (export e ...) u) 
+       (build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))]
+      [(_ u) 
+       (build-invoke-unit/infer #'u #t #f)]
+      [(_)
+       (raise-stx-err "missing unit" stx)]
+      [(_ . b)
        (raise-stx-err
-        (format "expected syntax matching (~a <define-unit-identifier>)"
+        (format "expected syntax matching (~a [(export <define-signature-identifier>)] <define-unit-identifier>) or (~a  [(export <define-signature-identifier>)] (link <define-unit-identifier> ...))"
-                (syntax-e (stx-car stx)))))))
+                (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
   
   (define-for-syntax (temp-id-with-tags id i)
     (syntax-case i (tag)
@@ -1770,18 +1873,15 @@
   
   (define-syntax/err-param (invoke-unit/infer stx)
     (syntax-case stx ()
-      ((_ u) 
+      [(_ (link unit ...))
-       (let ((ui (lookup-def-unit #'u)))
+       (build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)]
-         (with-syntax (((isig ...) (map unprocess-tagged-id
+      [(_ u) (build-invoke-unit/infer #'u #f #f)]
-                                        (unit-info-import-sig-ids ui))))
+      [(_)
-           (quasisyntax/loc stx
+       (raise-stx-err "missing unit" stx)]
-             (invoke-unit u (import isig ...))))))
+      [(_ . b)
-      ((_)
-       (raise-stx-err "missing unit" stx))
-      ((_ . b)
        (raise-stx-err
-        (format "expected syntax matching (~a <define-unit-identifier>)"
+        (format "expected syntax matching (~a <define-unit-identifier>) or (~a (link <define-unit-identifier> ...))"
-                (syntax-e (stx-car stx)))))))
+                (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
   
   (define-for-syntax (build-unit/s stx)
     (syntax-case stx (import export init-depend)

collects/net/mime.ss

@@ -30,21 +30,17 @@
 (require scheme/unit
          "mime-sig.ss"
          "mime-unit.ss"
-         "qp-sig.ss"
          "qp.ss"
-         "base64-sig.ss"
          "base64.ss"
-         "head-sig.ss"
          "head.ss")
 
-(define-unit-from-context base64@ base64^)
+;(define-unit-from-context base64@ base64^)
-(define-unit-from-context qp@ qp^)
+;(define-unit-from-context qp@ qp^)
-(define-unit-from-context head@ head^)
+;(define-unit-from-context head@ head^)
 
-(define-compound-unit/infer mime@2 (import) (export mime^)
+(define-values/invoke-unit/infer 
-  (link base64@ qp@ head@ mime@))
+  (export mime^)
-
+  (link mime@))
-(define-values/invoke-unit/infer mime@2)
 
 (provide-signature-elements mime^)
 

collects/scribblings/reference/units.scrbl

@@ -484,18 +484,29 @@ with the declared imports and exports, otherwise the
 @exnraise[exn:fail:contract] when the @scheme[define-unit-binding]
 form is evaluated.}
 
-@defform[(invoke-unit/infer unit-id)]{
+@defform/subs[
+#:literals (link)
+(invoke-unit/infer unit-spec)
+[(unit-spec unit-id (link link-unit-id ...))]]{
 
 Like @scheme[invoke-unit], but uses static information associated with
 @scheme[unit-id] to infer which imports must be assembled from the
-current context.}
+current context.  If given a link form containing multiple
+@scheme[link-unit-id]s, then the units are first linked via
+@scheme[define-compound-unit/infer].}
 
-@defform[(define-values/invoke-unit/infer unit-id)]{
+@defform/subs[
+#:literals (link)
+(define-values/invoke-unit/infer maybe-exports unit-spec)
+[(maybe-exports code:blank (export tagged-sig-spec ...))
+ (unit-spec unit-id (link link-unit-id ...))]]{
 
 Like @scheme[define-values/invoke-unit], but uses static information
 associated with @scheme[unit-id] to infer which imports must be
 assembled from the current context and what exports should be bound
-by the definition.}
+by the definition.  If given a link form containing multiple
+@scheme[link-unit-id]s, then the units are first linked via
+@scheme[define-compound-unit/infer].}
 
 @; ------------------------------------------------------------------------
 

collects/tests/units/test-unit.ss

@@ -1304,6 +1304,30 @@
 (test-syntax-error "define-compound-unit: bad name"
   (define-compound-unit 1 (import) (link) (export)))
 
+(test-syntax-error "invoke-unit/infer : no unit"
+  (invoke-unit/infer))
+(test-syntax-error "invoke-unit/infer : not a unit"
+  (invoke-unit/infer 1))
+(test-syntax-error "invoke-unit/infer : not a unit"
+  (let ([x 1]) (invoke-unit/infer x)))
+(test-syntax-error "invoke-unit/infer : not a unit"
+  (let-syntax ([x 1]) (invoke-unit/infer x)))
+(test-syntax-error "invoke-unit/infer: too much"
+  (invoke-unit/infer x y))
+
+(define-unit u (import x-sig) (export))
+(define-unit v (import) (export x-sig) (define x 3))
+
+(test-syntax-error "invoke-unit/infer : no unit"
+  (invoke-unit/infer (link)))
+(test-syntax-error "invoke-unit/infer : not a unit"
+  (invoke-unit/infer (link 1 u)))
+(test-syntax-error "invoke-unit/infer : not a unit"
+  (let ([x 1]) (invoke-unit/infer (link u x))))
+(test-syntax-error "invoke-unit/infer : not a unit"
+  (let-syntax ([x 1]) (invoke-unit/infer (link x u))))
+(invoke-unit/infer (link u v))
+
 (test-syntax-error "define-values/invoke-unit/infer: no unit"
   (define-values/invoke-unit/infer))
 (test-syntax-error "define-values/invoke-unit/infer: not a unit"
@@ -1317,7 +1341,46 @@
 (test-syntax-error "define-values/invoke-unit/infer: too much"
   (define-values/invoke-unit/infer x y))
 
-(define-unit u (import x-sig) (export))
+(define-unit u (import x-sig) (export) x)
+(define-unit v (import) (export x-sig) (define x 3))
+
+(test-syntax-error "define-values/invoke-unit/infer: no unit"
+  (define-values/invoke-unit/infer (link)))
+(test-syntax-error "define-values/invoke-unit/infer: not a unit"
+  (define-values/invoke-unit/infer (link 1 u)))
+(test-syntax-error "define-values/invoke-unit/infer: not a unit"
+  (let ([x 1])
+    (define-values/invoke-unit/infer (link u x))))
+(test-syntax-error "define-values/invoke-unit/infer: not a unit"
+  (let-syntax ([x 1])
+    (define-values/invoke-unit/infer (link u x))))
+(let ()
+  (define-values/invoke-unit/infer (link u v))
+  x)
+
+
+(let ()
+  (define-values/invoke-unit/infer (export x-sig) (link u v))
+  x)
+(let ()
+  (define-values/invoke-unit/infer (export x-sig) v)
+  x)
+(test-syntax-error "define-values/invoke-unit/infer: doesn't export y"
+  (define-values/invoke-unit/infer (export y-sig) (link u v)))
+
+(test-runtime-error exn? "unbound variable: x"
+  (let ()
+    (define-values/invoke-unit/infer (export) (link u v))
+    x))
+(test-syntax-error "define-values/invoke-unit/infer: doesn't export y"
+  (define-values/invoke-unit/infer (export y-sig) v))
+(test-runtime-error exn? "unbound variable: x"
+   (let ()
+     (define-values/invoke-unit/infer (export) v)
+     x))
+
+
+(define-unit u (import x-sig) (export) x)
 (test-syntax-error "define-values/invoke-unit/infer: bad imports"
   (define-values/invoke-unit/infer u))
 (define-unit u (import x-sig y-sig) (export))

collects/typed-scheme/infer/infer.ss

@@ -3,10 +3,11 @@
 (require (except-in "../utils/utils.ss" infer))
 (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss"
          "restrict.ss" "promote-demote.ss"
-         (only-in scheme/unit provide-signature-elements)
+         (only-in scheme/unit provide-signature-elements
+                  define-values/invoke-unit/infer link)
          (utils unit-utils))
          
 (provide-signature-elements restrict^ infer^)
 
-(define-values/link-units/infer
+(define-values/invoke-unit/infer
-  infer@ constraints@ dmap@ restrict@ promote-demote@)
+  (link infer@ constraints@ dmap@ restrict@ promote-demote@))

collects/typed-scheme/typecheck/typechecker.ss

@@ -3,7 +3,9 @@
 (require "../utils/utils.ss")
 (require (utils unit-utils)
          mzlib/trace
-         (only-in scheme/unit provide-signature-elements)
+         (only-in scheme/unit
+                  provide-signature-elements
+                  define-values/invoke-unit/infer link)
          "signatures.ss" "tc-toplevel.ss"         
          "tc-if-unit.ss" "tc-lambda-unit.ss" "tc-app-unit.ss"
          "tc-let-unit.ss" "tc-dots-unit.ss"
@@ -11,5 +13,5 @@
 
 (provide-signature-elements typechecker^ tc-expr^)
 
-(define-values/link-units/infer
+(define-values/invoke-unit/infer
-  tc-toplevel@ tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@)
+  (link tc-toplevel@ tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@))

collects/typed-scheme/utils/unit-utils.ss

@@ -1,13 +1,8 @@
 #lang scheme/base
 
-(require scheme/unit
+(require scheme/unit (for-syntax scheme/base))
-         (for-syntax
-          scheme/base
-          (only-in srfi/1/list s:member delete-duplicates)
-          scheme/unit-exptime
-          scheme/match))
 
-(provide define-values/link-units/infer cnt)
+(provide cnt)
 
 (define-signature-form (cnt stx)
   (syntax-case stx ()
@@ -15,105 +10,5 @@
      (list #'nm)
      #;(list #'[contracted (nm cnt)])]))
 
-(define-syntax (define-values/link-units/infer stx)
-  ;; construct something we can put in the imports/exports clause from the datum
-  (define (datum->sig-elem d)
-    (if (car d)
-        (quasisyntax/loc (cdr d) (tag . #,(cdr d)))
-        (cdr d)))
-  
-  ;; identifier -> (list (listof imports) (listof exports))
-  (define (get-sigs id)
-    (define-values (imps exps) (unit-static-signatures id id))
-    (list imps exps))
-  
-  ;; flatten one level of a list
-  ;; listof[listof[a]] -> listof[a]
-  (define (flatten l) (apply append l))
-  
-  ;; returns two lists of sig-elems
-  (define (get-all-sigs ids)
-    (define imps/exps (map get-sigs ids))
-    (define-values (imps exps) (values (map car imps/exps) (map cadr imps/exps)))
-    (values (flatten imps) (flatten exps)))
-  
-  ;; construct the runtime code
-  ;; takes 3 lists of identifiers and a syntax object for location info
-  (define (mk imports exports units stx)
-    (quasisyntax/loc stx
-      (begin (define-compound-unit/infer new-unit@ 
-               (import #,@imports)
-               (export #,@exports)
-               (link #,@units))
-             (define-values/invoke-unit/infer new-unit@))))
-  
-  ;; compares two signature datums for equality
-  (define (sig=? sig1 sig2)
-    (and (eq? (car sig1) (car sig2))
-         (or (symbol? (car sig1)) (not (car sig1)))
-         (bound-identifier=? (cdr sig1) (cdr sig2))))
-  
-  ;; is imp in the list of exports?
-  (define (sig-in-sigs? imp exps)
-    (for/or ([e exps]) (sig=? imp e)))
-  
-  ;; produce the imports not satisfied by the exports, and all the exports
-  ;; exports should not have duplicates
-  (define (imps/exps-from-units units)
-    (let-values ([(imps exps) (get-all-sigs units)])
-      (let* ([exps* (map datum->sig-elem exps)]
-             [imps* (map datum->sig-elem (filter (lambda (imp) (not (sig-in-sigs? imp exps))) imps))])
-        (values imps* exps*))))
-
-  (define (duplicates? sigs)
-    (for/or ([s sigs]
-             #:when
-             (> 1 (length (for/list ([s* sigs] #:when (free-identifier=? s s*)) s*))))
-            s))
-  
-  (syntax-case stx (import export)
-    ;; here the exports are specified - they ought to be a subset of the allowable exports
-    [(_ (export . sigs) . units)
-     (let*-values ([(units) (syntax->list #'units)]
-                   [(imps exps) (imps/exps-from-units units)])
-       (mk imps (syntax->list #'sigs) units stx))]
-    ;; here we just export everything that's available
-    [(_ . units)
-     (andmap identifier? (syntax->list #'units))
-     (let*-values ([(units) (syntax->list #'units)]
-                   [(imps exps) (imps/exps-from-units units)])
-       (cond [(duplicates? exps)
-              =>
-              (lambda (d)
-                (raise-syntax-error #f (format "multiple units export the signature ~a" d) stx))]
-             [else 
-              (mk (delete-duplicates imps) exps units stx)]))]))
 
 
-;; Tests
-#|
-(define-signature x^ (x))
-(define-signature y^ (y))
-(define-signature z^ (z))
-
-(define-unit y@
-  (import z^)
-  (export y^)
-  (define y (* 2 z)))
-
-(define-unit x@
-  (import y^)
-  (export x^)
-  (define (x) (+ y 1)))
-
-(define z 45)
-
-(define-values/link-units/infer (export x^) x@ y@)
-(define-signature y^ (y))
- (define-unit x@ (import y^) (export))
- (define-unit z@ (import y^) (export))
- (define-values/link-units/infer x@ z@)
-
-;(define-values/link-units/infer x@ y@)
-|#
-