[db] checkpoint, basic tests working

private/db.rkt

@@ -0,0 +1,258 @@
+#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
+    (only-in racket/string string-split)
+    ;; --- query
+    (only-in racket/port with-input-from-string)
+    (only-in racket/format ~a)
+    racket/match
+    (for-syntax syntax/parse racket/syntax typed/racket/base)
+    ;; --- ???
+    syntax/parse
+    syntax/stx
+    trivial/private/common
+))
+
+(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))))
+)
+
+;; =============================================================================
+
+(begin-for-syntax
+
+  ;; -- schema = ((DB-NAME (ROW-TYPE ...))
+  ;;              ...)
+
+  (define (schema-parser stx)
+    (define x** (cadr (syntax->datum stx)))
+    (cond
+     [(and (list? x**)
+           (for/and ([x* (in-list x**)])
+             (and (= 2 (length x*))
+                  (symbol? (car x*))
+                  (list? (cadr x*))
+                  (for/and ([r (in-list (cadr x*))])
+                    (and (pair? r)
+                         (symbol? (car r))
+                         (symbol? (cdr r)))))))
+      x**]
+     [else #f]))
+
+  (define-values (schema-key schema? schema-def schema-let)
+    (make-value-property 'db:schema schema-parser))
+  (define-syntax-class/predicate schema/expand schema?)
+
+  (define (table-mem schema db)
+    (for/first ([tbl-schema (in-list schema)]
+                #:when (eq? db (car tbl-schema)))
+      (cadr tbl-schema)))
+
+  (define (row-mem tbl-schema row)
+    (for/first ([row-schema (in-list tbl-schema)]
+                #:when (eq? (car row-schema) row))
+      (cdr row-schema)))
+
+  (define (resolve-wildcard tbl-schema row)
+    (cond
+     [(eq? row '*)
+      (map car tbl-schema)]
+     [(list? row)
+      row]
+     [else
+      (list row)]))
+
+  (define (row-ref->type schema qrow)
+    (define q* (string-split qrow "."))
+    (case (length q*)
+     [(1)
+      ;; Make sure that row exists SOMEWHERE in table
+      (global-row-mem schema (string->symbol (car q*)))]
+     [(2)
+      ;; Have table name + row name, make sure they match
+      (let ([tbl (table-mem schema (string->symbol (car q*)))])
+        (and tbl (row-mem tbl (string->symbol (cadr q*)))))]
+     [else
+      (error 'internal-error "Failed to parse query-row '~a'" qrow)]))
+
+  (define (global-row-mem schema row)
+    (let loop ([acc #f]
+               [schema schema])
+      (cond
+       [(null? schema)
+        acc]
+       [(row-mem (cadr (car schema)) row)
+        => (lambda (t)
+        (if acc #f (loop t (cdr schema))))]
+       [else
+        (loop acc (cdr schema))])))
+
+  (define (condition*->type* schema condition* #:src stx)
+    (define unsorted
+      (for/fold ([acc '()])
+                ([condition (in-list condition*)])
+        (define typ (row-ref->type schema (car condition)))
+        (unless typ
+          (raise-syntax-error 'query-row:
+            "Failed to resolve type for row" (syntax->datum stx) condition))
+        (define val (cdr condition))
+        (define varnum (sql-variable? val))
+        (if varnum
+          (cons (cons typ varnum) acc)
+          acc)))
+    (for/list ([typ+num (sort unsorted string<? #:key cdr)]
+               [num (in-naturals 1)])
+      (unless (= (cdr typ+num) num)
+        (raise-syntax-error 'query-row:
+          (format "Missing query parameter '~a'" num)
+          (syntax->datum stx)))
+      (car typ+num)))
+
+  ;; --------------------------------------------------------------------------
+
+  (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?)
+
+  ;; --------------------------------------------------------------------------
+  ;; -- query
+
+  (define (query-parser stx)
+    (define str (if (string? (syntax-e stx)) (syntax-e stx) (quoted-stx-value? stx)))
+    (and
+     (string? str)
+     (match (with-input-from-string (string-append "(" str ")") read)
+      [(list (? select?) sel (? from?) database rest* ...)
+       (define condition* (condition-parser rest*))
+       (list sel database condition*)]
+      [_ #f])))
+
+  (define (symbol-ci=? s1 s2)
+    (and
+     (symbol? s1)
+     (symbol? s2)
+     (string-ci=? (symbol->string s1) (symbol->string s2))))
+
+  (define-syntax (define-sql-keyword-predicate stx)
+    (syntax-parse stx
+     [(_ kwd*:id ...)
+      #:with (kwd?* ...) (for/list ([kwd (in-list (syntax-e #'(kwd* ...)))])
+                           (format-id stx "~a?" (syntax-e kwd)))
+      (syntax/loc stx
+        (begin (define (kwd?* v) (symbol-ci=? v 'kwd*)) ...))]))
+
+  (define-sql-keyword-predicate
+    select
+    from
+    where
+    and)
+
+  ;; Check for query parameters. Currently only for Postgres.
+  (define (sql-variable? s)
+    (define str (~a s))
+    (and
+      (= 2 (string-length str))
+      (eq? #\$ (string-ref str 0))
+      (string->number (string (string-ref str 1)))))
+
+  (define (condition-parser v*)
+    (let loop ([v* v*])
+      (match v*
+       ['()
+        '()]
+       [(list (or (? where?) (? and?)) db+row '= v rest* ...)
+        (cons (cons (~a db+row) (~a v))
+              (loop rest*))]
+       [(cons _ rest*)
+        (loop rest*)])))
+
+  (define-values (query-key query? query-def query-let)
+    (make-value-property 'db:query query-parser))
+  (define-syntax-class/predicate query/expand query?)
+
+)
+
+(define-syntax define-schema: (make-keyword-alias 'define schema-def))
+(define-syntax let-schema: (make-keyword-alias 'let schema-let))
+(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)]))
+
+(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*))
+    (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]))))
+

private/format.rkt

@@ -59,12 +59,8 @@
           (loop (+ i 1) acc)]))]
      [else #f]))
 
-  (define-values (
+  (define-values (_key fmt? _define _let)
-    _key
+    (make-value-property 'string:format format-parser))
-    fmt?
-    _define
-    _let
-   ) (make-value-property 'string:format format-parser))
 
   (define-syntax-class/predicate string/format fmt?)
 )

test/db-pass.rkt

@@ -0,0 +1,33 @@
+#lang typed/racket/base
+
+;(module+ test
+  (require
+    trivial/vector
+    trivial/private/db)
+  (define-type Id Natural)
+  (define-schema: M '((word
+                       [(id   . Id)
+                        (word . String)])
+                      (word_syllables
+                       [(word      . Id)
+                        (syllables . Id)])))
+  (define-connection: c (postgresql-connect: M #:user "ben" #:database "ipoe"))
+
+  (define r0 (query-row: c "SELECT * FROM word LIMIT 1"))
+  (ann r0 (Vector Id String))
+
+  (define r1 (query-row: c "SELECT * FROM word WHERE word.word = \"blossom\""))
+  (ann r1 (Vector Id String))
+
+  (define r2 (query-row: c "SELECT * FROM word WHERE word.word = $1" "blossom"))
+  (ann r2 (Vector Id String))
+
+  (define-vector: r3 (query-row: c "SELECT id FROM word WHERE word.id = 1"))
+  (ann r3 (Vector Id))
+
+  ;(vector-ref: r3 2)
+  ;(vector-ref: (vector-map: add1 r3) 3) ;; Yes
+
+  ;(query-row: c "SELECT * FROM word WHERE word.word = $1 word.id = $2" "blossom")
+  ;(query-row: c "SELECT * FROM word WHERE word.word = $1 word.id = $4" "blossom" 2)
+