added struct-guard/c

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -1,7 +1,8 @@
 #lang scribble/doc
 @(require "mz.rkt")
 @(require (for-label syntax/modcollapse
-                     racket/stxparam))
+                     racket/stxparam
+                     racket/serialize))
 
 @(define contract-eval
    (lambda ()
@@ -1785,6 +1786,11 @@ the original structure-type name does not act as a constructor.
 If the @racket[#:omit-constructor] option is present, the constructor
 is not provided.
 
+Note that if the struct is created with @racket[serializable-struct]
+or @racket[define-serializable-struct], @racket[contract-out] does not
+protect struct instances that are created via
+@racket[deserialize]. Consider using @racket[struct-guard/c] instead.
+
 The @racket[#:∃], @racket[#:exists], @racket[#:∀], and @racket[#:forall]
 clauses define new abstract contracts. The variables are bound in the
 remainder of the @racket[contract-out] form to new contracts that hide
@@ -1842,6 +1848,19 @@ except that a @racket[_contract-expr] within @racket[provide/contract]
 is evaluated at the position of the @racket[provide/contract] form
 instead of at the end of the enclosing module.}
 
+@defform[(struct-guard/c contract-expr ...)]{
+  Returns a procedure suitable to be passed as the @racket[#:guard]
+ argument to @racket[struct], @racket[serializable-struct] (and related forms).
+ The guard procedure ensures that each contract protects the
+ corresponding field values, as long as the struct is not mutated.
+ Mutations are not protected.
+
+ @examples[#:eval (contract-eval) #:once
+           (struct snake (weight hungry?)
+             #:guard (struct-guard/c real? boolean?))
+           (eval:error (snake 1.5 "yep"))]
+}
+
 @subsection{Nested Contract Boundaries}
 @defmodule*/no-declare[(racket/contract/region)]
 @declare-exporting-ctc[racket/contract/region]

pkgs/racket-doc/scribblings/reference/serialization.scrbl

@@ -436,8 +436,8 @@ serializable with @racket[serialize].  This form is allowed only at
 the top level or in a module's top level (so that deserialization
 information can be found later).
 
-Serialization only supports cycles involving the created structure
-type when all fields are mutable (or when the cycle can be broken
+Serialization supports cycles involving the created structure
+type only when all fields are mutable (or when the cycle can be broken
 through some other mutable value).
 
 In addition to the bindings generated by @racket[struct],
@@ -456,6 +456,11 @@ information bound to
 @racketidfont{deserialize-info:}@racket[_id]@racketidfont{-v0}. See
 @racket[make-deserialize-info] for more information.
 
+Beware that the previous paragraph means that if a serializable struct
+is exported via @racket[contract-out], for example, the contracts are not
+checked during deserialization. Consider using @racket[struct-guard/c]
+instead.
+
 The @racket[-v0] suffix on the deserialization enables future
 versioning on the structure type through
 @racket[serializable-struct/versions].

pkgs/racket-test/tests/racket/contract/struct-type-property.rkt

@@ -3,7 +3,7 @@
 (require "test-util.rkt")
 
 (parameterize ([current-contract-namespace
-                (make-basic-contract-namespace)])
+                (make-basic-contract-namespace 'racket/contract/region)])
   (test/spec-passed
    'struct-type-prop.1
    '(let ()
@@ -74,4 +74,33 @@
       (define s3 (s list?))
       ((prop-ref s3) 'apple)))
 
+  (test/spec-failed
+   'struct-guard/c.1
+   '(let ()
+      (with-contract pos
+        #:result any/c
+        (let ()
+          (struct s (x y) #:guard (struct-guard/c integer? boolean?))
+          (s 1 1))))
+   "(region pos)")
+
+  (test/spec-failed
+   'struct-guard/c.2
+   '(let ()
+      (with-contract pos
+        #:result any/c
+        (let ()
+          (struct s (x y) #:guard (struct-guard/c integer? boolean?))
+          (s #t #f))))
+   "(region pos)")
+
+  (test/spec-passed/result
+   'struct-guard/c.3
+   '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^the-name-of-the-struct, field 2:"
+                                                     (exn-message x)))])
+      (struct the-name-of-the-struct (x y) #:guard (struct-guard/c integer? boolean?))
+      (the-name-of-the-struct 1 1))
+   #t)
+   
+  
   )

racket/collects/racket/contract/base.rkt

@@ -143,6 +143,7 @@
  get/build-val-first-projection
 
  suggest/c
+ struct-guard/c
 
  ;; not documented.... (ie unintentional export)
  n->th)

racket/collects/racket/contract/private/base.rkt

@@ -71,7 +71,7 @@
 (define (apply-contract c v pos neg name loc context-limit)
   ((make-apply-contract c pos neg name loc context-limit) v))
 
-(define (make-apply-contract c pos neg name loc context-limit)
+(define (make-apply-contract c pos neg name loc context-limit [backwards? #f])
   (let ([c (coerce-contract 'contract c)])
     (check-source-location! 'contract loc)
     (define clnp (contract-late-neg-projection c))

racket/collects/racket/contract/private/blame.rkt

@@ -446,6 +446,10 @@
 (define (blame/important-original? blme)
   (define i (blame-important blme))
   (cond
+    [(equal? (blame-positive blme) (blame-negative blme))
+     ;; if the positive and negative parties are the same,
+     ;; we never want to say "broke its own contract"
+     #f]
     [i (equal? (important-sense-swapped? i) (blame-original? blme))]
     [else (blame-original? blme)]))
 

racket/collects/racket/contract/private/struct-prop.rkt

@@ -1,8 +1,12 @@
 #lang racket/base
 (require "guts.rkt"
          "blame.rkt"
-         "prop.rkt")
-(provide (rename-out [struct-type-property/c* struct-type-property/c]))
+         "prop.rkt"
+         "base.rkt"
+         (for-syntax racket/base)
+         syntax/location)
+(provide (rename-out [struct-type-property/c* struct-type-property/c])
+         struct-guard/c)
 
 (define (get-stpc-late-neg-proj stpc)
   (define get-late-neg-proj
@@ -47,3 +51,61 @@
            (struct-type-property/c
             (coerce-contract 'struct-type-property/c value-contract)))])
     struct-type-property/c))
+
+(define-syntax (struct-guard/c stx)
+  (syntax-case stx ()
+    [(_ . args)
+     #`(struct-guard/c/proc (quote-srcloc #,stx)
+                            (current-contract-region)
+                            . args)]))
+
+(define (struct-guard/c/proc loc blame-party . ctc-args)
+  (define ctcs
+    (for/list ([arg (in-list ctc-args)]
+               [i (in-naturals)])
+      (define ctc (coerce-contract/f arg))
+      (unless ctc
+        (apply raise-argument-error
+               'struct-guard/c
+               "contract?"
+               i
+               ctc-args))
+      ctc))
+
+  ;; don't want to depend on racket/list, so duplicate this
+  ;; (plus we know that it will always be a non-empty list,
+  ;;  so skip some checks)
+  (define (last l)
+    (let loop ([l l])
+      (if (pair? (cdr l)) (loop (cdr l)) (car l))))
+  
+  (define number-of-contracts (length ctcs))
+  
+  ;; would like to have this be specialized to the number of
+  ;; arguments there actually are, but given the fact that
+  ;; we're creating blame objects and projections after getting
+  ;; the arguments it doesn't seem worth bothering for now
+  ;; (we are creating the projections late because we don't
+  ;; get the `name` until later on)
+  (λ args
+    (define name (last args))
+    (unless (= (length args) (+ number-of-contracts 1))
+      (error 'struct-guard/c
+             "given ~a contracts, but the struct ~s has ~a fields"
+             number-of-contracts
+             name
+             (- (length args) 1)))
+    (define ctc-projs
+      (for/list ([ctc (in-list ctcs)]
+                 [i (in-naturals 1)])
+        (make-apply-contract ctc
+                             blame-party blame-party
+                             (if (= number-of-contracts 1)
+                                 name
+                                 (format "~a, field ~a" name i))
+                             loc
+                             #f)))
+    (apply values
+           (for/list ([arg (in-list args)]
+                      [proj (in-list ctc-projs)])
+             (proj arg)))))