schema: add contracts (1/?)

telebot/private/schema.rkt

@@ -19,6 +19,7 @@
 ;; - provide transformer `schema-out`
 ;; - field converter?
 ;; - add contracts
+;; - cooperate with check-syntax
 ;; - schema union
 
 (define json-undefined ;; though json doesn't have "undefined" type
@@ -30,6 +31,26 @@
 
 (define (true? x) (eq? x #t))
 
+(define (jsexpr->integer x)
+  (unless (integer? x)
+    (raise-argument-error 'jsexpr->integer "integer?" x))
+  x)
+
+(define (jsexpr->string x)
+  (unless (string? x)
+    (raise-argument-error 'jsexpr->string "string?" x))
+  x)
+
+(define (jsexpr->boolean x)
+  (unless (boolean? x)
+    (raise-argument-error 'jsexpr->boolean "boolean?" x))
+  x)
+
+(define (jsexpr->true x)
+  (unless (true? x)
+    (raise-argument-error 'jsexpr->true "#t" x))
+  x)
+
 (define-syntax optional
   (lambda (stx)
     (raise-syntax-error #f "optional should be used in define-schema" stx)))
@@ -54,7 +75,7 @@
         string->symbol
         (datum->syntax id _)))
 
-  (struct schema-info (struct-id fields from-jsexpr to-jsexpr))
+  (struct schema-info (struct-id pred fields from-jsexpr to-jsexpr))
 
   (define-syntax-class schema-id
     #:attributes (info)
@@ -63,32 +84,42 @@
                    (define local-value (syntax-local-value info-id (lambda () #f)))]
              #:fail-unless (schema-info? local-value)
              "expected an identifier for a schema name"
-             #:attr info local-value))
+             #:attr info local-value
+             #:with struct-id (schema-info-struct-id local-value)
+             #:attr fields (schema-info-fields local-value)))
 
   (define-syntax-class schema
     #:literals (integer? string? boolean? true? listof)
-    #:attributes (struct-id fields from-jsexpr to-jsexpr)
-    (pattern (~or integer? string? boolean? true?)
-             #:attr struct-id #f
-             #:attr fields '()
-             #:with from-jsexpr #'values
+    #:attributes (contract from-jsexpr to-jsexpr)
+    (pattern integer?
+             #:with contract #'integer?
+             #:with from-jsexpr #'jsexpr->integer
+             #:with to-jsexpr #'values)
+    (pattern string?
+             #:with contract #'string?
+             #:with from-jsexpr #'jsexpr->string
+             #:with to-jsexpr #'values)
+    (pattern boolean?
+             #:with contract #'boolean?
+             #:with from-jsexpr #'jsexpr->boolean
+             #:with to-jsexpr #'values)
+    (pattern true?
+             #:with contract #'true?
+             #:with from-jsexpr #'jsexpr->true
              #:with to-jsexpr #'values)
     (pattern (listof s:schema)
-             #:attr struct-id #f
-             #:attr fields '()
+             #:with contract #'(listof s.contract)
              #:with from-jsexpr #'(lambda (jsexpr) (map s.from-jsexpr jsexpr))
              #:with to-jsexpr #'(lambda (jsexpr) (map s.to-jsexpr jsexpr)))
     (pattern id:schema-id
              #:do [(define local-value (attribute id.info))]
-             #:with struct-id (schema-info-struct-id local-value)
-             #:attr fields (schema-info-fields local-value)
+             #:with contract (schema-info-pred local-value)
              #:with from-jsexpr (schema-info-from-jsexpr local-value)
              #:with to-jsexpr (schema-info-to-jsexpr local-value))
     ;; this clause is a temporal fallback for recursive schema definition
     ;; TODO: distinguish the strict and the loose situation
     (pattern id:id
-             #:attr struct-id #f
-             #:attr fields '()
+             #:with contract #f
              #:attr from-jsexpr #f
              #:attr to-jsexpr #f))
 
@@ -131,6 +162,7 @@
   (syntax-parse stx
     [(_ name:id fld:field ...)
      #:with schema-info-id (format-id #'name "schema:~a" #'name)
+     #:with pred-id (format-id #'name "~a?" #'name)
      #:with ctor-id (format-id #'name "make-~a" #'name)
      #:with jsexpr->name (format-id #'name "jsexpr->~a" #'name)
      #:with name->jsexpr (format-id #'name "~a->jsexpr" #'name)
@@ -150,6 +182,7 @@
 
          (define-syntax schema-info-id
            (schema-info #'name
+                        #'pred-id
                         (list #'fld ...)
                         #'jsexpr->name
                         #'name->jsexpr)))]))
@@ -169,9 +202,9 @@
               #'(let ([val (hash-ref jsexpr 'key json-undefined)])
                   (if (json-undefined? val) val (fld.from-jsexpr val)))
               #'(let ([val (hash-ref jsexpr 'key
-                                     (lambda () (raise-argument-error
-                                                 'jsexpr->schema
-                                                 "field \"~a\" is missed" 'key)))])
+                                     (lambda ()
+                                       (error 'jsexpr->schema
+                                              "field \"~a\" is missed" 'key)))])
                   (fld.from-jsexpr val)))]))
      #'(define (jsexpr->schema jsexpr)
          (struct-id field-value ...))]))
@@ -206,29 +239,36 @@
 (define-syntax (%ref stx)
   (syntax-parse stx
     [(_ schema value () (~optional failed)) #'value]
-    [(_ schema:schema expr (key:ref-key more ...) (~optional failed))
+    [(_ schema:schema-id expr (key:ref-key more ...) (~optional failed))
+     #:do [(define schema-info (attribute schema.info))]
      #:with field:field
-     (let loop ([fields (attribute schema.fields)])
+     (let loop ([fields (schema-info-fields schema-info)])
        (cond
          [(null? fields)
-          (raise-syntax-error 'ref (format "schema ~a don't have the field ~a"
-                                           (syntax-e #'schema) (syntax-e #'key.trimed))
+          (raise-syntax-error 'ref
+                              (format "schema ~a don't have the field ~a"
+                                      (syntax-e #'schema) (syntax-e #'key.trimed))
                               #f #'key)]
          [else
           (syntax-parse (car fields)
             [fld:field
              #:when (equal? (syntax-e #'fld.name) (syntax-e #'key.trimed))
              #'fld]
             [_ (loop (cdr fields))])]))
-     #:with struct-id #'schema.struct-id
+     #:with struct-id (schema-info-struct-id schema-info)
      #:with accessor (format-id #'struct-id "~a-~a" #'struct-id #'key.trimed)
      (if (attribute field.opt?)
          #'(let ([val (accessor expr)])
              (if (json-undefined? val)
-                 (~? failed (raise-argument-error 'ref "the field ~a is undefined" 'key.trimed))
+                 (~? failed (error 'ref "the field ~a is undefined" 'key.trimed))
                  (%ref field.schema val (more ...) (~? failed))))
          #'(let ([val (accessor expr)])
-             (%ref field.schema val (more ...) (~? failed))))]))
+             (%ref field.schema val (more ...) (~? failed))))]
+    [(_ schema expr (key more ...) (~optional failed))
+     (raise-syntax-error 'ref
+                         (format "schema ~a don't have fields"
+                                 (syntax->datum #'schema))
+                         #f #'key)]))
 
 (define-syntax (define-api stx)
   (syntax-parse stx