diff --git a/telebot/api.rkt b/telebot/api.rkt index a83605e..a2f10f2 100644 --- a/telebot/api.rkt +++ b/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))) diff --git a/telebot/private/schema.rkt b/telebot/private/schema.rkt index 26d6a5d..f78f6e6 100644 --- a/telebot/private/schema.rkt +++ b/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 (:)