schema: first attempt to support recursive schema definition

telebot/api.rkt

@@ -20,15 +20,15 @@
   (chat chat)
   (text (optional string?)))
 
-(define-schema reply-params
-  (message-id integer?))
-
 (define-schema response
   (chat-id integer?)
   (text string?)
   (parse-mode (optional string?))
   (reply (optional reply-params) "reply_parameters"))
 
+(define-schema reply-params
+  (message-id integer?))
+
 (define-schema update
   (id integer? "update_id")
   (message (optional message)))

telebot/private/schema.rkt

@@ -19,6 +19,7 @@
 ;; - provide transformer `schema-out`
 ;; - field converter?
 ;; - add contracts
+;; - schema union
 
 (define json-undefined ;; though json doesn't have "undefined" type
   (let ()
@@ -55,17 +56,18 @@
 
   (struct schema-info (struct-id fields from-jsexpr to-jsexpr))
 
+  (define-syntax-class schema-id
+    #:attributes (info)
+    (pattern id:id
+             #:do [(define info-id (format-id #'id "schema:~a" #'id))
+                   (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))
+
   (define-syntax-class schema
     #:literals (integer? string? boolean? true? listof)
     #:attributes (struct-id fields from-jsexpr to-jsexpr)
-    (pattern id:id
-             #:with info-id (format-id #'id "schema:~a" #'id)
-             #:do [(define local-value (syntax-local-value #'info-id (lambda () #f)))]
-             #:when (schema-info? local-value)
-             #:with struct-id (schema-info-struct-id local-value)
-             #:attr fields (schema-info-fields local-value)
-             #:with from-jsexpr (schema-info-from-jsexpr local-value)
-             #:with to-jsexpr (schema-info-to-jsexpr local-value))
     (pattern (~or integer? string? boolean? true?)
              #:attr struct-id #f
              #:attr fields '()
@@ -75,7 +77,20 @@
              #:attr struct-id #f
              #:attr fields '()
              #:with from-jsexpr #'(lambda (jsexpr) (map s.from-jsexpr jsexpr))
-             #:with to-jsexpr #'(lambda (jsexpr) (map s.to-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 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 '()
+             #:attr from-jsexpr #f
+             #:attr to-jsexpr #f))
 
   (define-syntax-class schema/opt
     #:literals (optional)
@@ -92,8 +107,8 @@
                  (kebab-case->snake-case/id #'name))
              #:with schema #'type+.type
              #:attr opt? (attribute type+.opt?)
-             #:with from-jsexpr #'type+.type.from-jsexpr
-             #:with to-jsexpr #'type+.type.to-jsexpr))
+             #:attr from-jsexpr (attribute type+.type.from-jsexpr)
+             #:attr to-jsexpr (attribute type+.type.to-jsexpr)))
 
   (define-syntax-class ref-key
     #:attributes (trimed)
@@ -102,13 +117,6 @@
              #:fail-unless (string-prefix? key/str ".") "key should start with \".\""
              #:with trimed (datum->syntax #'id (string->symbol (substring key/str 1)))))
 
-  (define-template-metafunction (make-field-failed stx)
-    (syntax-parse stx
-      [(_ converter-id fld:field)
-       (if (attribute fld.opt?)
-           #'json-undefined
-           #'(lambda () (error 'converter-id "field \"~a\" is missed" 'fld.key)))]))
-
   (define-template-metafunction (make-field-kw-arg stx)
     (syntax-parse stx
       [(_ fld:field)
@@ -117,11 +125,7 @@
                                 (string->keyword (symbol->string (syntax-e #'name))))
        (if (attribute fld.opt?)
            #'(kw [name json-undefined])
-           #'(kw name))]))
-
-  (define-template-metafunction (make-accessor stx)
-    (syntax-parse stx
-      [(_ id fld:field) (format-id #'id "~a-~a" #'id #'fld.name)])))
+           #'(kw name))])))
 
 (define-syntax (define-schema stx)
   (syntax-parse stx
@@ -130,6 +134,12 @@
      #: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)
+
+     (syntax-local-lift-module-end-declaration
+      #'(begin
+          (define-jsexpr->schema name jsexpr->name)
+          (define-schema->jsexpr name name->jsexpr)))
+
      #'(begin
          (struct name (fld.name ...)
            ;; #:constructor-name struct-ctor-id
@@ -138,24 +148,52 @@
          (define (ctor-id (~@ . (make-field-kw-arg fld)) ...)
            (name fld.name ...))
 
-         (define (jsexpr->name jsexpr)
-           (name (fld.from-jsexpr
-                  (hash-ref jsexpr 'fld.key (make-field-failed jsexpr->name fld)))
-                 ...))
-
-         (define (name->jsexpr data)
-           (define jsexpr (make-hash))
-           (let ([fld-v ((make-accessor name fld) data)])
-             (unless (json-undefined? fld-v)
-               (hash-set! jsexpr 'fld.key (fld.to-jsexpr fld-v)))) ...
-           jsexpr)
-
          (define-syntax schema-info-id
            (schema-info #'name
                         (list #'fld ...)
                         #'jsexpr->name
                         #'name->jsexpr)))]))
 
+(define-syntax (define-jsexpr->schema stx)
+  (syntax-parse stx
+    [(_ schema:schema-id jsexpr->schema:id)
+     #:do [(define schema-info (attribute schema.info))
+           (define fields (schema-info-fields schema-info))]
+     #:with struct-id (schema-info-struct-id schema-info)
+     #:with (field-value ...)
+     (for/list ([fld (in-list fields)])
+       (syntax-parse fld
+         [fld:field
+          #:with key #'fld.key
+          (if (attribute fld.opt?)
+              #'(let ([val (hash-ref jsexpr 'key json-undefined)])
+                  (if (json-undefined? val) val (fld.from-jsexpr val)))
+              #'(hash-ref jsexpr 'key
+                          (lambda () (raise-argument-error 'jsexpr->schema "field \"~a\" is missed" 'key))))]))
+     #'(define (jsexpr->schema jsexpr)
+         (struct-id field-value ...))]))
+
+(define-syntax (define-schema->jsexpr stx)
+  (syntax-parse stx
+    [(_ schema:schema-id schema->jsexpr:id)
+     #:do [(define schema-info (attribute schema.info))
+           (define fields (schema-info-fields schema-info))]
+     #:with struct-id (schema-info-struct-id schema-info)
+     #:with (set-field-value ...)
+     (for/list ([fld (in-list fields)])
+       (syntax-parse fld
+         [fld:field
+          #:with accessor (format-id #'struct-id "~a-~a" #'struct-id #'fld.name)
+          (if (attribute fld.opt?)
+              #'(let ([fld-val (accessor data)])
+                  (unless (json-undefined? fld-val)
+                    (hash-set! jsexpr 'fld.key (fld.to-jsexpr fld-val))))
+              #'(hash-set! jsexpr 'fld.key (fld.to-jsexpr (accessor data))))]))
+     #'(define (schema->jsexpr data)
+         (let ([jsexpr (make-hash)])
+           set-field-value ...
+           jsexpr))]))
+
 (define-syntax (ref stx)
   (syntax-parse stx
     #:literals (:)