Add data type guards

type/record.scrbl

@@ -58,12 +58,15 @@ obvious order to those pieces.
    (code:line #:accessor-name accessor-id)
    (code:line #:pattern-name pattern-id)
    (code:line #:property-maker prop-maker-expr)
+   (code:line #:guard-maker guard-maker-expr)
    (code:line #:inspector inspector-expr)])
 
  #:contracts
  ([prop-maker-expr
    (-> uninitialized-record-descriptor?
        (listof (cons/c struct-type-property? any/c)))]
+  [guard-maker-expr
+   (or/c #f (-> uninitialized-record-descriptor? procedure?))]
   [inspector-expr inspector?])]{
  Creates a new @tech{record type} named @racket[id] and binds the following
  identifiers:
@@ -103,12 +106,12 @@ obvious order to those pieces.
  @racket[constructor-id] when used as an expression. Use
  @racket[#:omit-root-binding] when you want control over what @racket[id] is
  bound to, such as when creating a smart constructor.
- 
+
  The @racket[prop-maker-expr] is used to add structure type properties to the
- created type, and @racket[inspector-expr] is used to determine the
- @tech/reference{inspector} that will control the created type. See
- @racket[make-record-implementation] for more information about these
- parameters.
+ created type, @racket[guard-maker-expr] is used to create the guard procedure, and
+ @racket[inspector-expr] is used to determine the @tech/reference{inspector} that
+ will control the created type. See @racket[make-record-implementation] for more
+ information about these parameters.
 
  @(examples
    #:eval (make-evaluator) #:once
@@ -208,17 +211,44 @@ can access any field in the record: the per-field accessors created by
           [#:property-maker prop-maker
            (-> uninitialized-record-descriptor?
                (listof (cons/c struct-type-property? any/c)))
-           default-record-properties])
+           default-record-properties]
+          [#:guard-maker guard-maker
+           (or/c #f (-> uninitialized-record-descriptor? procedure?))
+           #f])
          initialized-record-descriptor?]{
  Implements @racket[type] and returns a @tech{type descriptor} for the new
- implementation. The @racket[inspector] argument behaves the same as in
+ implementation.
+
+ The @racket[inspector] argument behaves the same as in
  @racket[make-struct-type], although there are no transparent or prefab record
- types. The @racket[prop-maker] argument is similar to the corresponding
- argument of @racket[make-struct-implementation]. By default, record types are
+ types.
+
+ The @racket[prop-maker] argument is similar to the corresponding
+ argument of @racket[make-struct-implementation].
+
+ The @racket[guard-maker] argument is a procedure that should accept the partially
+ constructed record descriptor, and must return a guard procedure. This guard
+ procedure is similar to the one in @racket[make-struct-type]. It will accept
+ all the arguments to the record constructor as positional arguments,
+ sorted alphabetically by field name, and the values it returns will be the
+ values stored in the record.
+
+ By default, record types are
  created with properties that make them print like transparent structures,
  except field names are included --- see @racket[default-record-properties] for
  details.}
 
+@defform[(record-guard-maker/c keyword-contract-pair ...)
+
+         #:grammar
+         ([keyword-contract-pair
+           (code:line field-name-keyword field-contract)])]{
+ Returns a procedure suitable to be passed as the
+ @racket[#:guard-maker] argument to @racket[make-record-implementation]
+ or @racket[define-record-type]. The guard procedure will ensure that
+ the fields of the record are protected by their corresponding @racket[field-contract]s.
+ This is analogous to @racket[struct-guard/c].}
+
 @defproc[(record-descriptor-type [descriptor record-descriptor?]) record-type?]{
  Returns the @tech{record type} that @racket[descriptor] implements.}
 

type/record/descriptor.rkt

@@ -1,13 +1,15 @@
 #lang racket/base
 
-(require racket/contract/base)
+(require racket/contract/base racket/contract/region)
 
 (provide
+ record-guard-maker/c
  (contract-out
   [make-record-implementation
    (->* (record-type?)
         (#:inspector inspector?
-         #:property-maker (-> uninitialized-record-descriptor? properties/c))
+         #:property-maker (-> uninitialized-record-descriptor? properties/c)
+         #:guard-maker (or/c #f (-> uninitialized-record-descriptor? procedure?)))
         initialized-record-descriptor?)]
   [record-descriptor? predicate/c]
   [initialized-record-descriptor? predicate/c]
@@ -22,12 +24,14 @@
   [make-record-field-accessor (-> record-descriptor? natural? procedure?)]))
 
 (require racket/math
+         syntax/location
          rebellion/collection/keyset/low-dependency
          rebellion/custom-write
          rebellion/equal+hash
          rebellion/private/printer-markup
          rebellion/type/record/base
-         rebellion/type/tuple)
+         rebellion/type/tuple
+         (for-syntax racket/syntax racket/base syntax/parse))
 
 ;@------------------------------------------------------------------------------
 
@@ -107,13 +111,17 @@
 (define (make-record-implementation
          type
          #:inspector [inspector (current-inspector)]
-         #:property-maker [prop-maker default-record-properties])
+         #:property-maker [prop-maker default-record-properties]
+         #:guard-maker [guard-maker #f])
   (define (tuple-prop-maker descriptor)
     (prop-maker (tuple-descriptor->record-descriptor descriptor type)))
+  (define (tuple-guard-maker descriptor)
+    (guard-maker (tuple-descriptor->record-descriptor descriptor type)))
   (define descriptor
     (make-tuple-implementation (record-type->tuple-type type)
                                #:inspector inspector
-                               #:property-maker tuple-prop-maker))
+                               #:property-maker tuple-prop-maker
+                               #:guard-maker (and guard-maker tuple-guard-maker)))
   (tuple-descriptor->record-descriptor descriptor type))
 
 (define (record-type->tuple-type type)
@@ -153,6 +161,47 @@
        #:constructor constructor
        #:accessor accessor)))
 
+(define-syntax (record-guard-maker/c stx)
+  (define-splicing-syntax-class kw+contract
+    #:description "keyword contract pair"
+    (pattern (~seq kw:keyword ctc:expr)))
+  (syntax-parse stx
+    #:track-literals
+    [(_ contract-expr:kw+contract ...)
+     (define/with-syntax ([ctc-expr
+                           arg-sym
+                           arg-name-sym
+                           field-keyword
+                           field-name-string]
+                          ...)
+       (for/list ([kw+ctc (sort (map syntax-e (syntax-e #'(contract-expr ...)))
+                                keyword<?
+                                #:key (compose1 syntax-e car))])
+         (define-values (kw ctc) (apply values kw+ctc))
+         (list ctc (gensym) (gensym) kw (keyword->string (syntax-e kw)))))
+     (quasisyntax/loc stx
+       (let ([loc (quote-srcloc #,stx)]
+             [blame-party (current-contract-region)]
+             [expected-keys (keyset field-keyword ...)])
+         (λ (desc)
+           (define record-type (record-descriptor-type desc))
+           (define record-keys (record-type-fields record-type))
+           (define constructor-name (record-type-constructor-name record-type))
+           (define-values (arg-name-sym ...)
+             (values (format "~a, field ~a" constructor-name field-name-string) ...))
+           (unless (equal? expected-keys record-keys)
+             (raise-arguments-error
+              'record-guard-maker/c
+              "record field mismatch\n the expected fields do not match the given record descriptor"
+              "expected" expected-keys
+              "given" record-keys))
+           (λ (arg-sym ...)
+             (values
+              (contract ctc-expr arg-sym
+                        blame-party blame-party
+                        arg-name-sym loc)
+              ...)))))]))
+
 (define (default-record-properties descriptor)
   (define equal+hash (default-record-equal+hash descriptor))
   (define custom-write (default-record-custom-write descriptor))

type/record/private/definition-macro.rkt

@@ -77,7 +77,12 @@
      (~optional
       (~seq #:property-maker prop-maker:expr)
       #:defaults ([prop-maker #'default-record-properties])
-      #:name "#:property-maker option"))
+      #:name "#:property-maker option")
+
+     (~optional
+      (~seq #:guard-maker guard-maker:expr)
+      #:defaults ([guard-maker #'#f])
+      #:name "#:guard-maker option"))
     ...)
 
   #:with (field-accessor ...)
@@ -113,7 +118,8 @@
         #:constructor-name 'constructor
         #:accessor-name 'accessor)
        #:inspector inspector
-       #:property-maker prop-maker))
+       #:property-maker prop-maker
+       #:guard-maker guard-maker))
     (define predicate (record-descriptor-predicate descriptor))
     (define constructor (record-descriptor-constructor descriptor))
     (define accessor (record-descriptor-accessor descriptor))

type/tuple.scrbl

@@ -70,12 +70,14 @@ represent a single logical thing, and there is an obvious order to those pieces.
    (code:line #:accessor-name accessor-id)
    (code:line #:pattern-name pattern-id)
    (code:line #:property-maker prop-maker-expr)
+   (code:line #:guard-maker guard-maker-expr)
    (code:line #:inspector inspector-expr)])
 
  #:contracts
  ([prop-maker-expr
    (-> uninitialized-tuple-descriptor?
        (listof (cons/c struct-type-property? any/c)))]
+  [guard-maker-expr (or/c #f (-> uninitialized-tuple-descriptor? procedure?))]
   [inspector-expr inspector?])]{
  Creates a new @tech{tuple type} named @racket[id] and binds the following
  identifiers:
@@ -115,9 +117,10 @@ represent a single logical thing, and there is an obvious order to those pieces.
  such as when creating a smart constructor.
 
  The @racket[prop-maker-expr] is used to add structure type properties to the
- created type, and @racket[inspector-expr] is used to determine the
- @tech/reference{inspector} that will control the created type. See
- @racket[make-tuple-implementation] for more information about these parameters.
+ created type, @racket[guard-maker-expr] is used to create the guard procedure, and
+ @racket[inspector-expr] is used to determine the @tech/reference{inspector} that
+ will control the created type. See @racket[make-tuple-implementation] for more
+ information about these parameters.
 
  @(examples
    #:eval (make-evaluator) #:once
@@ -203,14 +206,27 @@ field in the tuple: the per-field accessors created by
   [#:property-maker prop-maker
    (-> uninitialized-tuple-descriptor?
        (listof (cons/c struct-type-property? any/c)))
-   default-tuple-properties])
+   default-tuple-properties]
+  [#:guard-maker guard-maker
+   (or/c #f (-> uninitialized-tuple-descriptor? procedure?)) #f])
  initialized-tuple-descriptor?]{
  Implements @racket[type] and returns a @tech{type descriptor} for the new
- implementation. The @racket[guard] and @racket[inspector] arguments behave the
+ implementation.
+
+ The @racket[guard] and @racket[inspector] arguments behave the
  same as the corresponding arguments of @racket[make-struct-type], although
- there are no transparent or prefab tuple types. The @racket[prop-maker]
- argument is similar to the corresponding argument of @racket[
- make-struct-implementation]. By default, tuple types are created with
+ there are no transparent or prefab tuple types.
+
+ The @racket[prop-maker] argument is similar to the corresponding argument
+ of @racket[make-struct-implementation].
+
+ The @racket[guard-maker] argument is a procedure that should accept the partially
+ constructed tuple descriptor, and must return a guard procedure. This guard
+ procedure is similar to the one in @racket[make-struct-type]: it will accept all
+ the arguments to the tuple constructor and the values it returns will be the values
+ stored in the tuple.
+
+ By default, tuple types are created with
  properties that make them print and compare in a manner similar to transparent
  structure types --- see @racket[default-tuple-properties] for details.
 
@@ -225,6 +241,13 @@ field in the tuple: the per-field accessors created by
    (point-x (point 42 888))
    (point-y (point 42 888)))}
 
+@defform[(tuple-guard-maker/c contract-expr ...)]{
+ Returns a procedure suitable to be passed as the
+ @racket[#:guard-maker] argument to @racket[make-tuple-implementation]
+ or @racket[define-tuple-type]. The guard procedure will ensure that
+ the tuple fields are protected by @racket[contract-expr]s.
+ This is analogous to @racket[struct-guard/c].}
+
 @defproc[(tuple-descriptor-type [descriptor tuple-descriptor?]) tuple-type?]{
  Returns the @tech{tuple type} that @racket[descriptor] implements.}