diff --git a/telebot/private/schema.rkt b/telebot/private/schema.rkt index 1720918..b9f0ba3 100644 --- a/telebot/private/schema.rkt +++ b/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,13 +239,15 @@ (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) @@ -220,15 +255,20 @@ #: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