wrap-expr/c: improve performance, add #:arg?, fix pos/neg args

- Improve performance by using make-apply-contract, lifting,
  fast path for dependent flat contracts.
- The positive blame party now consistently means the *macro def*
  and the negative party means the *macro use*. The #:arg? argument
  controls blame swapping.

pkgs/racket-doc/syntax/scribblings/contract.scrbl

@@ -14,14 +14,15 @@ contracts to macro subexpressions.
 
 @defproc[(wrap-expr/c [contract-expr syntax?]
                       [expr syntax?]
+                      [#:arg? arg? any/c #t]
                       [#:positive pos-blame
                                   (or/c syntax? string? module-path-index?
                                         'from-macro 'use-site 'unknown)
-                                  'use-site]
+                                  'from-macro]
                       [#:negative neg-blame
                                   (or/c syntax? string? module-path-index?
                                         'from-macro 'use-site 'unknown)
-                                  'from-macro]
+                                  'use-site]
                       [#:name expr-name
                               (or/c identifier? symbol? string? #f) #f]
                       [#:macro macro-name
@@ -68,7 +69,9 @@ The other arguments have the same meaning as for @racket[expr/c].
 (app (lambda (x) 'pear) 5)
 ]
 
-@history[#:added "6.3"]{}
+@history[#:added "6.3" #:changed "7.2.0.3" @elem{Added the
-}
+@racket[#:arg?] keyword argument and changed the default values and
+interpretation of the @racket[#:positive] and @racket[#:negative]
+arguments.}]}
 
 @close-eval[the-eval]

pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl

@@ -40,4 +40,25 @@ expressions. The @racket[expr/c] syntax class does not change how
 pattern variables are bound; it only computes an attribute that
 represents the checked expression.
 
+The previous example shows a macro applying a contract on an argument,
+but a macro can also apply a contract to an expression that it
+produces. In that case, it should use @racket[#:arg? #f] to indicate
+that the macro, not the calling context, is responsible for expression
+produced.
+
+@interaction[#:eval the-eval
+(code:comment "BUG: rationals not closed under inversion")
+(define-syntax (invert stx)
+  (syntax-parse stx
+    [(_ e)
+     #:declare e (expr/c #'rational?)
+     #:with result #'(/ 1 e.c)
+     #:declare result (expr/c #'rational? #:arg? #f)
+     #'result.c]))
+
+(invert 4)
+(invert 'abc)
+(invert 0.0)
+]
+
 @(close-eval the-eval)

pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl

@@ -84,28 +84,36 @@ using @racket[#:literals] or @racket[~literal].
                state under the key @racket['literals].}]}
 
 @defstxclass[(expr/c [contract-expr syntax?]
+                     [#:arg? arg? any/c #t]
                      [#:positive pos-blame
                       (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown)
-                      'use-site]
+                      'from-macro]
                      [#:negative neg-blame
                       (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown)
-                      'from-macro]
+                      'use-site]
                      [#:name expr-name (or/c identifier? string? symbol?) #f]
                      [#:macro macro-name (or/c identifier? string? symbol?) #f]
-                     [#:context ctx (or/c syntax? #f) #, @elem{determined automatically}])]{
+                     [#:context context (or/c syntax? #f) #, @elem{determined automatically}])]{
 
 Accepts an expression (@racket[expr]) and computes an attribute
 @racket[c] that represents the expression wrapped with the contract
-represented by @racket[contract-expr].
+represented by @racket[contract-expr]. Note that
+@racket[contract-expr] is potentially evaluated each time the code
+generated by the macro is run; for the best performance,
+@racket[contract-expr] should be a variable reference.
 
-The contract's positive blame represents the obligations of the
+The positive blame represents the obligations of the macro imposing
-expression being wrapped. The negative blame represents the
+the contract---the ultimate user of @racket[expr/c].  The contract's
-obligations of the macro imposing the contract---the ultimate user
+negative blame represents the obligations of the expression being
-of @racket[expr/c]. By default, the positive blame is taken as
+wrapped.  By default, the positive blame is inferred from the
-the module currently being expanded, and the negative blame is
+definition site of the macro (itself inferred from the
-inferred from the definition site of the macro (itself inferred from
+@racket[context] argument), and the negative blame is taken as the
-the @racket[context] argument), but both blame locations can be
+module currently being expanded, but both blame locations can be
-overridden.
+overridden. When @racket[arg?] is @racket[#t], the term being matched
+is interpreted as an argument (that is, coming from the negative
+party); when @racket[arg?] is @racket[#f], the term being matched is
+interpreted as a result of the macro (that is, coming from the
+positive party).
 
 The @racket[pos-blame] and @racket[neg-blame] arguments are turned
 into blame locations as follows:
@@ -151,7 +159,10 @@ See @secref{exprc} for an example.
 @racket[c] attribute. The @racket[expr/c] syntax class does not change how
 pattern variables are bound; it only computes an attribute that
 represents the checked expression.
-}
+
+@history[#:changed "7.2.0.3" @elem{Added the @racket[#:arg?] keyword
+argument and changed the default values and interpretation of the
+@racket[#:positive] and @racket[#:negative] arguments.}]}
 
 
 @section{Literal Sets}

pkgs/racket-test/tests/stxparse/test-exprc.rkt

@@ -0,0 +1,70 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/parse)
+         racket/contract
+         rackunit)
+
+;; See also tests/syntax/contract/test-errors.rkt.
+
+(define-syntax (m-str stx)
+  (syntax-parse stx
+    [(_ e)
+     #:declare e (expr/c #'string?)
+     #'e.c]))
+
+(check-equal? (m-str "string") "string")
+(check-exn #rx"m-str: contract violation.*expected: string?"
+           (lambda () (m-str 'not-a-string)))
+
+(define-syntax (m-arr stx)
+  (syntax-parse stx
+    [(_ f arg)
+     #:declare f (expr/c #'(-> string? any))
+     #'(f.c arg)]))
+
+(check-equal? (m-arr string->symbol "a") 'a)
+(check-exn #rx"m-arr: broke its own contract.*promised: string?"
+           (lambda () (m-arr string->symbol 'a)))
+
+(define-syntax (m-app stx)
+  (syntax-parse stx
+    [(_ ctc f arg)
+     #:declare f (expr/c #'ctc)
+     #'(f.c arg)]))
+
+(check-equal? (m-app (-> string? symbol?) string->symbol "A") 'A)
+(check-equal? ((m-app (-> string? (-> string? string?))
+                      (lambda (s) (lambda (t) (string-append s t)))
+                      "abc")
+               "def")
+              "abcdef")
+
+(check-exn #rx"m-app: broke its own contract.*promised: string?"
+           ;; Yes, it's m-app's fault, because it didn't protect
+           ;; f from bad arguments.
+           (lambda ()
+             ((m-app (-> string? (-> string? string?))
+                     (lambda (s) (lambda (t) (string-append s t)))
+                     "abc")
+              'def)))
+
+(define-syntax (m-res stx)
+  (syntax-parse stx
+    [(_ ctc v)
+     #:declare v (expr/c #'ctc #:arg? #f)
+     #'v.c]))
+
+(check-equal? (m-res string? "hello") "hello")
+(check-equal? (((m-res (-> string? (-> string? string?))
+                       (lambda (s) (lambda (t) (string-append s t))))
+                "abc") "def")
+              "abcdef")
+(check-exn #rx"m-res: contract violation.*expected: string?"
+           (lambda ()
+             (((m-res (-> string? (-> string? string?))
+                      (lambda (s) (lambda (t) (string-append s t))))
+               'abc) "def")))
+(check-exn #rx"m-res: contract violation.*expected: string?"
+           (lambda ()
+             (((m-res (-> string? (-> string? string?))
+                      (lambda (s) (lambda (t) (string-append s t))))
+               "abc") 'def)))

pkgs/racket-test/tests/syntax/contract/perf-liftable.rkt

@@ -0,0 +1,18 @@
+#lang racket/base
+
+;; Microbenchmark for expr/c with liftable contract.
+
+(module helper racket/base
+  (require (for-syntax racket/base syntax/parse))
+  (struct point (x y))
+  (define origin (point 0 0))
+  (define-syntax foo
+    (syntax-parser
+      [(_ (~var e (expr/c #'point?)))
+       #'e.c]))
+  (provide foo origin))
+(require 'helper)
+
+(time
+ (for ([i (in-range #e1e6)])
+   (foo origin)))

pkgs/racket-test/tests/syntax/contract/perf-nolift-result.rkt

@@ -0,0 +1,19 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/parse))
+
+;; Microbenchmark for expr/c with non-liftable *result* contract.
+;; See perf-nolift.rkt. The corresponding dependent contract is
+;;
+;;   (->i ([c contract?] [v any/c]) [_ (c) c])
+
+(struct point (x y))
+(define origin (point 0 0))
+
+(define-syntax foo
+  (syntax-parser
+    [(_ (~var e (expr/c #'point? #:arg? #f)))
+     #'e.c]))
+
+(time
+ (for ([i (in-range #e1e6)])
+   (foo origin)))

pkgs/racket-test/tests/syntax/contract/perf-nolift.rkt

@@ -0,0 +1,24 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/parse))
+
+;; Microbenchmark for expr/c with non-liftable contract.
+
+;; The contract expression cannot be lifted because point? is defined
+;; in the same module, and expr/c cannot be sure that the contract
+;; would be lifted to a point before the definition.
+
+;; On the other hand, this should be no worse than a dependent contract like
+;;
+;;   (->i ([c contract?] [v (c) c]) any)
+
+(struct point (x y))
+(define origin (point 0 0))
+
+(define-syntax foo
+  (syntax-parser
+    [(_ (~var e (expr/c #'point?)))
+     #'e.c]))
+
+(time
+ (for ([i (in-range #e1e6)])
+   (foo origin)))

pkgs/racket-test/tests/syntax/contract/test-errors.rkt

@@ -0,0 +1,81 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/contract)
+         racket/contract
+         rackunit)
+
+(define-syntax (m-str stx)
+  (syntax-case stx ()
+    [(_ e)
+     (wrap-expr/c #'string? #'e #:context stx)]))
+
+(check-equal? (m-str "string") "string")
+(check-exn #rx"m-str: contract violation.*expected: string?"
+           (lambda () (m-str 'not-a-string)))
+
+(define-syntax (m-arr stx)
+  (syntax-case stx ()
+    [(_ f arg)
+     (with-syntax ([f* (wrap-expr/c #'(-> string? any) #'f #:context stx)])
+       #'(f* arg))]))
+
+(check-equal? (m-arr string->symbol "a") 'a)
+(check-exn #rx"m-arr: broke its own contract.*promised: string?"
+           (lambda () (m-arr string->symbol 'a)))
+
+(define-syntax (m-app stx)
+  (syntax-case stx ()
+    [(_ f ctc arg)
+     (with-syntax ([f* (wrap-expr/c #'ctc #'f #:context stx)])
+       #'(f* arg))]))
+
+(check-equal? (m-app string->symbol (-> string? symbol?) "A") 'A)
+(check-equal? ((m-app (lambda (s) (lambda (t) (string-append s t)))
+                      (-> string? (-> string? string?))
+                      "abc")
+               "def")
+              "abcdef")
+
+(check-exn #rx"m-app: broke its own contract.*promised: string?"
+           ;; Yes, it's m-app's fault, because it didn't protect
+           ;; f from bad arguments.
+           (lambda ()
+             ((m-app (lambda (s) (lambda (t) (string-append s t)))
+                     (-> string? (-> string? string?))
+                     "abc")
+              'def)))
+
+(define-syntax (m-res stx)
+  (syntax-case stx ()
+    [(_ v ctc)
+     (wrap-expr/c #'ctc #'v #:arg? #f #:context stx)]))
+
+(check-equal? (m-res "hello" string?) "hello")
+(check-equal? (((m-res (lambda (s) (lambda (t) (string-append s t)))
+                      (-> string? (-> string? string?)))
+                "abc") "def")
+              "abcdef")
+(check-exn #rx"m-res: contract violation.*expected: string?"
+           (lambda ()
+             (((m-res (lambda (s) (lambda (t) (string-append s t)))
+                      (-> string? (-> string? string?)))
+               'abc) "def")))
+(check-exn #rx"m-res: contract violation.*expected: string?"
+           (lambda ()
+             (((m-res (lambda (s) (lambda (t) (string-append s t)))
+                      (-> string? (-> string? string?)))
+               "abc") 'def)))
+
+(let ()
+  (define fruit/c (and/c string? (or/c "orange" "peach" "strawberry")))
+  (define-syntax (smoothie stx)
+    (syntax-case stx ()
+      [(_ ing)
+       (with-syntax ([ing.c (wrap-expr/c #'fruit/c #'ing #:context stx)])
+         #'(format "icy blended ~s" ing.c))]))
+  (check-exn
+   (regexp
+    (string-append
+     "^smoothie: contract violation.*"
+     "given: \"kale\".*"
+     "in:.*\\(and/c string[?] \\(or/c \"orange\" \"peach\" \"strawberry\"\\)\\).*"))
+   (lambda () (smoothie "kale"))))

racket/collects/syntax/contract.rkt

@@ -1,7 +1,6 @@
 #lang racket/base
 (require racket/contract/base
          (for-template racket/base
-                       racket/contract/base
                        syntax/location)
          syntax/srcloc
          syntax/modcollapse
@@ -10,7 +9,8 @@
 (provide/contract
  [wrap-expr/c
   (->* (syntax? syntax?)
-       (#:positive (or/c syntax? string? module-path-index?
+       (#:arg? any/c
+        #:positive (or/c syntax? string? module-path-index?
                          'from-macro 'use-site 'unknown)
         #:negative (or/c syntax? string? module-path-index?
                          'from-macro 'use-site 'unknown)
@@ -19,30 +19,107 @@
         #:context (or/c syntax? #f))
        syntax?)])
 
-(module macro-arg/c racket/base
+(module runtime racket/base
-  (require racket/contract/base
+  (require (for-syntax racket/base
-           racket/contract/combinator)
+                       syntax/free-vars)
+           racket/contract/base
+           racket/contract/combinator
+           (only-in racket/contract/private/base
+                    make-apply-contract))
+  (provide expr/contract
+           relative-source)
 
-  (provide macro-arg/c)
+  (define (macro-expr/c arg? expr-name ctc0)
+    (define ctc (coerce-contract 'wrap-expr/c ctc0))
+    (define proj (get/build-late-neg-projection ctc))
+    (make-contract
+     #:name (unquoted-printing-string
+             (format "macro ~a contract~a~a"
+                     (if arg? "argument" "result")
+                     (if expr-name " on " "")
+                     (if expr-name expr-name "")))
+     #:first-order (contract-first-order ctc)
+     #:late-neg-projection
+     (λ (blame)
+       (define blame* (blame-add-context blame (format "~s" (contract-name ctc)) #:swap? arg?))
+       (proj (blame-swap blame)))
+     #:list-contract? (list-contract? ctc)))
 
-  (define (macro-arg/c macro-name ctc)
+  (define (macro-dep-expr/c arg? expr-name)
-    (let ([ctc-project (get/build-late-neg-projection (coerce-contract 'wrap-expr/c ctc))])
+    (make-contract
-      ((cond [(flat-contract? ctc) make-flat-contract]
+     #:name (unquoted-printing-string
-             [(chaperone-contract? ctc) make-chaperone-contract]
+             (format "macro ~a contract~a~a"
-             [else make-contract])
+                     (if arg? "argument" "result")
-       #:name (contract-name ctc)
+                     (if expr-name " on " "")
-       #:first-order (contract-first-order ctc)
+                     (if expr-name expr-name "")))
-       #:late-neg-projection
+     #:late-neg-projection
-       (λ (blame)
+     (lambda (blame)
-         (let ([blame* (if macro-name (blame-add-context blame #f #:important macro-name) blame)])
+       (lambda (_f neg)
-           (ctc-project (blame-swap blame*))))
+         ;; Note: specialized to _f = return-second-arg.
-       #:list-contract? (list-contract? ctc)))))
+         (lambda (c v)
+           (define (slow-path)
+             (define ctc (coerce-contract 'wrap-expr/c c))
+             (define proj (get/build-late-neg-projection ctc))
+             (define blame*
+               (blame-add-context blame (format "~s" (contract-name ctc)) #:swap? arg?))
+             ((proj blame*) v neg))
+           (cond [(flat-contract? c)
+                  (let ([c (if (procedure? c) c (coerce-contract 'wrap-expr/c c))])
+                    (if (c v) v (slow-path)))]
+                 [else (slow-path)]))))))
 
-(require (for-template 'macro-arg/c))
+  (define (return-second-arg c v) v)
+
+  (begin-for-syntax
+    (define (okay-to-lift? ee)
+      (and (identifier? ee) (not (local-free-vars? ee))))
+    (define (self-module-path-index? mpi)
+      (define-values (rel base) (module-path-index-split mpi))
+      (and (eq? rel #f) (eq? (module-path-index-submodule mpi) #f)))
+    (define (local-free-vars? ee)
+      (for/or ([fv (in-list (free-vars ee #:module-bound? #t))])
+        (define b (identifier-binding fv))
+        (cond [(list? b) (self-module-path-index? (car b))]
+              [else #t]))))
+
+  (define-syntax (expr/contract stx)
+    (cond
+      [(eq? (syntax-local-context) 'expression)
+       (syntax-case stx ()
+         [(_ val-expr ctc-expr arg? expr-name [mac-arg ...])
+          (let ([ctc-ee (local-expand #'ctc-expr 'expression null)])
+            (cond [(okay-to-lift? ctc-ee)
+                   #`(#,(syntax-local-lift-expression
+                         #`(make-apply-contract
+                            (macro-expr/c arg? expr-name #,ctc-ee)
+                            mac-arg ...))
+                      val-expr)]
+                  [else
+                   #`(#,(syntax-local-lift-expression
+                         #`((make-apply-contract
+                             (macro-dep-expr/c arg? expr-name)
+                             mac-arg ...)
+                            return-second-arg))
+                      #,ctc-ee
+                      val-expr)]))])]
+      [else #`(#%expression #,stx)]))
+
+  (define (relative-source base-mpi rel-mod-path)
+    (define r
+      (resolved-module-path-name
+       (module-path-index-resolve
+        (module-path-index-join rel-mod-path base-mpi))))
+    (cond [(pair? r)
+           (cons 'submod r)]
+          [(symbol? r)
+           (list 'quote r)]
+          [else r])))
+(require (for-template (submod "." runtime)))
 
 (define (wrap-expr/c ctc-expr expr
-                     #:positive [pos-source 'use-site]
+                     #:arg? [arg? #t]
-                     #:negative [neg-source 'from-macro]
+                     #:positive [pos-source 'from-macro]
+                     #:negative [neg-source 'use-site]
                      #:name [expr-name #f]
                      #:macro [macro-name #f]
                      #:context [ctx (current-syntax-context)])
@@ -63,32 +140,14 @@
                  (syntax-case ctx ()
                    [(x . _) (identifier? #'x) (syntax-e #'x)]
                    [x (identifier? #'x) (syntax-e #'x)]
-                   [_ #f])]
+                   [_ '?])]
-                [else #f])])
+                [else '?])])
-    (base-wrap-expr/c expr #`(macro-arg/c '#,macro-name #,ctc-expr)
+    #`(expr/contract #,expr #,ctc-expr #,arg? '#,expr-name
-                      #:positive pos-source-expr
+                     [#,pos-source-expr
-                      #:negative neg-source-expr
+                      #,neg-source-expr
-                      #:expr-name (cond [(and macro-name expr-name)
+                      '#,macro-name
-                                         (format "~a of ~a" expr-name macro-name)]
+                      (quote-syntax #,expr)
-                                        [(or macro-name expr-name)
+                      #f])))
-                                         => (λ (name) (format "~a" name))]
-                                        [else #f])
-                      #:source #`(quote-syntax #,expr))))
-
-(define (base-wrap-expr/c expr ctc-expr
-                          #:positive positive
-                          #:negative negative
-                          #:expr-name expr-name
-                          #:source source)
-  (let ([expr-name (or expr-name #'#f)]
-        [source (or source #'#f)])
-    (quasisyntax/loc expr
-      (contract #,ctc-expr
-                #,expr
-                #,negative
-                #,positive
-                #,expr-name
-                #,source))))
 
 (define (get-source-expr source ctx)
   (cond [(eq? source 'use-site)
@@ -128,17 +187,3 @@
           (cond [(list? b) (car b)] ;; module-path-index
                 [else 'use-site]))
         'unknown)))
-
-(module source racket/base
-  (provide relative-source)
-  (define (relative-source base-mpi rel-mod-path)
-    (define r
-      (resolved-module-path-name
-       (module-path-index-resolve
-        (module-path-index-join rel-mod-path base-mpi))))
-    (cond [(pair? r)
-           (cons 'submod r)]
-          [(symbol? r)
-           (list 'quote r)]
-          [else r])))
-(require (for-template (submod "." source)))

racket/collects/syntax/parse/experimental/contract.rkt

@@ -10,8 +10,9 @@
 (define not-given (gensym))
 
 (define-syntax-class (expr/c ctc-stx
-                             #:positive [pos-blame 'use-site]
+                             #:arg? [arg? #t]
-                             #:negative [neg-blame 'from-macro]
+                             #:positive [pos-blame 'from-macro]
+                             #:negative [neg-blame 'use-site]
                              #:macro [macro-name #f]
                              #:name [expr-name not-given]
                              #:context [ctx #f])
@@ -21,6 +22,7 @@
            #:with
            c (wrap-expr/c ctc-stx
                           #'y
+                          #:arg? arg?
                           #:positive pos-blame
                           #:negative neg-blame
                           #:name (if (eq? expr-name not-given)
@@ -31,7 +33,8 @@
 
 (provide-syntax-class/contract
  [expr/c (syntax-class/c (syntax?)
-                         (#:positive (or/c syntax? string? module-path-index?
+                         (#:arg? any/c
+                          #:positive (or/c syntax? string? module-path-index?
                                            'from-macro 'use-site 'unknown)
                           #:negative (or/c syntax? string? module-path-index?
                                            'from-macro 'use-site 'unknown)