core: add support for string fragments

Author: Bogdanp

deta-doc/deta.scrbl

@@ -615,6 +615,10 @@ queries.
       (~> (from ,table #:as t)
           (where (= (fragment (ast:qualified "t" column)) "bogdan")))))
   ]
+
+  @history[
+    #:changed "0.15" @elem{Added support for string fragments.}
+  ]
 }
 @defop[ilike (display (select _ (ilike "A" "%a%")))]
 @defop[in (display (select _ (in 5 '(1 2 3 4 5))))]

deta-lib/info.rkt

@@ -1,7 +1,7 @@
 #lang info
 
 (define license 'BSD-3-Clause)
-(define version "0.14")
+(define version "0.15")
 (define collection "deta")
 
 (define deps '("base"

deta-lib/private/ast.rkt

@@ -25,10 +25,12 @@
  expr?
  expr-terminal?
 
+ make-fragment
  (struct-out app)
  (struct-out as)
  (struct-out case-e)
  (struct-out column)
+ (struct-out fragment)
  (struct-out ident)
  (struct-out placeholder)
  (struct-out qualified)
@@ -54,6 +56,9 @@
 (struct column expr (e)
   #:transparent)
 
+(struct fragment expr (e)
+  #:transparent)
+
 (struct ident expr (name)
   #:transparent)
 
@@ -72,6 +77,12 @@
 (struct table expr (e)
   #:transparent)
 
+(define (make-fragment e)
+  (cond
+    [(string? e) (fragment e)]
+    [(expr? e) e]
+    [else (raise-argument-error 'fragment "(or/c string? expr?)" e)]))
+
 
 ;; clauses ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

deta-lib/private/dialect/standard.rkt

@@ -64,6 +64,9 @@
     [(table e)  (write-expr e)]
     [(column e) (write-expr e)]
 
+    [(fragment s)
+     (write-string s)]
+
     [(ident i)
      (write-string (ident->string i))]
 

deta-lib/query.rkt

@@ -360,7 +360,8 @@
 
   (define-syntax-class fragment-expr
     #:literals (fragment)
-    (pattern (fragment node:expr) #:with e #'node))
+    (pattern (fragment node:expr)
+             #:with e #'(ast:make-fragment node)))
 
   (define-syntax-class subquery-expr
     #:literals (subquery)

deta-test/deta/query.rkt

@@ -2,6 +2,7 @@
 
 (require db
          deta
+         (prefix-in ast: deta/private/ast)
          deta/private/meta
          gregor
          racket/match
@@ -318,7 +319,7 @@
 
         (check-true (null? all-active-users))
 
-        (match-define (list active-user-jim active-user-bob)
+        (match-define (list _active-user-jim active-user-bob)
           (insert! (current-conn)
                    (make-user #:username "[email protected]"
                               #:active? #t)
@@ -422,7 +423,33 @@
      (test-case "can fail to look up entities"
        (check-false (lookup (current-conn)
                             (~> (from user #:as u)
-                                (where #f)))))))))
+                                (where #f))))))
+
+    (test-suite
+     "fragment"
+
+     (test-case "fragment with ast nodes"
+       (check-equal?
+        (with-output-to-string
+          (lambda ()
+            (display
+             (~> (from user #:as u)
+                 (select u.name)
+                 (where (fragment (ast:app
+                                   (ast:ident '=)
+                                   (list (ast:qualified "u" "name")
+                                         (ast:scalar "Bogdan")))))))))
+        "#<query: SELECT u.name FROM users AS u WHERE u.name = 'Bogdan'>"))
+
+     (test-case "fragment with string"
+       (check-equal?
+        (with-output-to-string
+          (lambda ()
+            (display
+             (~> (from user #:as u)
+                 (select u.name)
+                 (where (fragment "u.name = 'Bogdan'"))))))
+        "#<query: SELECT u.name FROM users AS u WHERE u.name = 'Bogdan'>"))))))
 
 (module+ test
   (require rackunit/text-ui)