113 lines
3.5 KiB
Racket
113 lines
3.5 KiB
Racket
#lang typed/racket/base
|
|
|
|
;; TODO do not use this library, it's just for demonstration
|
|
|
|
(provide
|
|
(all-from-out db)
|
|
|
|
;(rename-out [quasiquote DB]) ;; TODO try using struct types
|
|
|
|
define-schema:
|
|
define-connection:
|
|
postgresql-connect:
|
|
|
|
;query-exec:
|
|
query-row:
|
|
;query-maybe-row:
|
|
|
|
;; define schema
|
|
;; start connection
|
|
;; query-exec
|
|
)
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
(require
|
|
(only-in trivial/private/vector vector-length-key)
|
|
(for-syntax
|
|
typed/racket/base
|
|
racket/syntax
|
|
;; --- ???
|
|
syntax/parse
|
|
syntax/stx
|
|
trivial/private/common
|
|
trivial/private/db/schema
|
|
trivial/private/db/query
|
|
))
|
|
|
|
(require/typed db
|
|
(#:opaque Connection connection?)
|
|
(postgresql-connect (->* [#:user String #:database String] [] Connection))
|
|
(query-row (-> Connection String Any * (Vectorof Any)))
|
|
(query-maybe-row (-> Connection String Any * (Option (Vectorof Any))))
|
|
)
|
|
|
|
;; =============================================================================
|
|
|
|
(define-syntax define-schema: (make-keyword-alias 'define schema-def))
|
|
(define-syntax let-schema: (make-keyword-alias 'let schema-let))
|
|
|
|
(begin-for-syntax
|
|
(define (connection-parser stx)
|
|
;; Connections have no primitive form -- need to use a wrapped API function
|
|
#f)
|
|
|
|
(define-values (connection-key connection? connection-def connection-let)
|
|
(make-value-property 'db:connection connection-parser))
|
|
(define-syntax-class/predicate connection/expand connection?)
|
|
)
|
|
|
|
(define-syntax define-connection: (make-keyword-alias 'define connection-def))
|
|
(define-syntax let-connection: (make-keyword-alias 'let connection-let))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
(define-syntax (postgresql-connect: stx)
|
|
(syntax-parse stx
|
|
[(_ s:schema/expand e* ...)
|
|
(syntax-property
|
|
(syntax/loc stx (postgresql-connect e* ...))
|
|
connection-key
|
|
#'s.evidence)]))
|
|
|
|
;; TODO query-maybe-row
|
|
|
|
(define-syntax query-row: (make-alias #'query-row
|
|
(lambda (stx) (syntax-parse stx
|
|
[(_ c:connection/expand q:query/expand arg* ...)
|
|
(define schema (syntax->datum #'c.evidence))
|
|
(define-values (maybe-row* table condition*)
|
|
(apply values (syntax->datum #'q.evidence)))
|
|
;; -- Check connection vs. schema
|
|
(define tbl-schema (table-mem schema table))
|
|
(unless tbl-schema
|
|
(raise-syntax-error 'query-row: "Unknown table" (syntax->datum stx) table))
|
|
(define row* (resolve-wildcard tbl-schema maybe-row*))
|
|
(when (null? row*)
|
|
(raise-syntax-error 'query-row: "Empty selection" (syntax->datum stx) 'q.expanded))
|
|
(define result-type*
|
|
(for/list ([r (in-list row*)])
|
|
(or (row-mem tbl-schema r)
|
|
(raise-syntax-error 'query-row "Unknown row" (syntax->datum stx) r))))
|
|
(define type* (condition*->type* schema condition* #:src stx))
|
|
;; -- Check number of arguments
|
|
(let ([num-expected (length type*)]
|
|
[num-actual (length (syntax-e #'(arg* ...)))])
|
|
(unless (= num-expected num-actual)
|
|
(apply raise-arity-error
|
|
'query-row:
|
|
num-expected
|
|
(map syntax->datum (syntax-e #'(arg* ...))))))
|
|
(define (id->type id) (format-id stx "~a" id))
|
|
(with-syntax ([(t* ...) (map id->type type*)]
|
|
[vec-stx (format-id stx "Vector")]
|
|
[(r-t* ...) (map id->type result-type*)])
|
|
(syntax-property
|
|
(syntax/loc stx
|
|
(cast (query-row c.expanded q.expanded (ann arg* t*) ...)
|
|
(vec-stx r-t* ...)))
|
|
vector-length-key
|
|
(length result-type*)))]
|
|
[_ #f]))))
|
|
|