#lang scheme/base (require (for-syntax scheme/base scheme/match srfi/26/cut (planet untyped/unlib:3/syntax) "base.ss" "persistent-struct-info.ss") scheme/class "quick-find-internal.ss" "sql/sql.ss") ; Helpers ---------------------------------------- ; syntax boolean syntax syntax syntax syntax -> syntax (define-for-syntax (make-quick-find stx count? struct-stx snooze-stx method-stx order-stx) (let* ([info ; persistent-struct-info (with-handlers ([exn? (lambda (exn) (raise-syntax-error #f "not a persistent struct" stx struct-stx))]) (persistent-struct-info-ref struct-stx))] [entity-stx ; syntax e.g. entity:struct (persistent-struct-info-entity-id info)] [attr-stxs ; (listof syntax) e.g. (list attr:attr1 atr:attr2 ...) (persistent-struct-info-attribute-ids info)] [key-stxs ; (listof syntax) e.g. (list #:attr1 #:attr2 ...) (map (lambda (sym) (string->keyword (symbol->string sym))) (persistent-struct-info-attribute-names info))] ; (listof syntax) e.g. (list attr1 attr2 ...) [arg-stxs (map (cut datum->syntax #f <>) (persistent-struct-info-attribute-names info))] ; (listof syntax) e.g. (list #:attr1 [attr1 (void)] #:attr2 [attr2 (void)] ...) [key+arg-stxs (let loop ([key-stxs key-stxs] [arg-stxs arg-stxs]) (if (null? key-stxs) null (list* (car key-stxs) #`(#,(car arg-stxs) (void)) (loop (cdr key-stxs) (cdr arg-stxs)))))]) (with-syntax ([struct struct-stx] [struct-id (make-id struct-stx struct-stx '-id)] [snooze snooze-stx] [find-whatever method-stx] [entity entity-stx] [(attr ...) attr-stxs] [(key ...) key-stxs] [(arg ...) arg-stxs] [(key+arg ...) key+arg-stxs] [order order-stx]) (with-syntax ([what (if count? #'(count struct-id) #'struct)]) (syntax/loc stx (lambda (key+arg ...) (let-alias ([struct struct]) (send snooze find-whatever (sql (select #:what what #:from struct #:where ,(sql:and (or (void? arg) (quick-find-expression (sql:attr struct attr) arg)) ...) #:order order)))))))))) ; syntax syntax -> syntax (define-for-syntax (parse-kws stx kw-stx) ; syntax (define order-stx #'()) (let loop ([kw-stx kw-stx]) (syntax-case kw-stx () [() (values order-stx)] [(kw) (if (keyword? (syntax->datum #'kw)) (raise-syntax-error #f "no value for keyword" stx #'kw) (raise-syntax-error #f "not a valid keyword" stx #'kw))] [(kw val rest ...) (begin (match (syntax->datum #'kw) ['#:order (set! order-stx #'val)] [else (raise-syntax-error #f "not a valid keyword" stx #'kw)]) (loop #'(rest ...)))]))) ; Syntax ----------------------------------------- ; (_ struct-id snooze) -> (#:attr any ... -> (U persistent-struct #f)) (define-syntax (custom-find-count stx) (syntax-case stx () [(_ struct snooze kw ...) (make-quick-find stx #t #'struct #'snooze #'find-one #'())])) ; (_ struct-id snooze) -> (#:attr any ... -> (U persistent-struct #f)) (define-syntax (custom-find-one stx) (syntax-case stx () [(_ struct snooze kw ...) (let-values ([(order-stx) (parse-kws stx #'(kw ...))]) (make-quick-find stx #f #'struct #'snooze #'find-one order-stx))])) ; (_ struct-id snooze) -> (#:attr any ... -> (listof persistent-struct)) (define-syntax (custom-find-all stx) (syntax-case stx () [(_ struct snooze kw ...) (let-values ([(order-stx) (parse-kws stx #'(kw ...))]) (make-quick-find stx #f #'struct #'snooze #'find-all order-stx))])) ; (_ struct-id snooze) -> (#:attr any ... -> (gen-> persistent-struct)) (define-syntax (custom-g:find stx) (syntax-case stx () [(_ struct snooze kw ...) (let-values ([(order-stx) (parse-kws stx #'(kw ...))]) (make-quick-find stx #f #'struct #'snooze #'g:find order-stx))])) ; Provide statements ----------------------------- (provide custom-find-count custom-find-one custom-find-all custom-g:find)