factor: trim using lists

[factor.git] / basis / db / tuples / tuples.factor

diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
index 19d4be5fc8aa8c238ee97398104aa4093c46748c..e620f34286f8ebd2ff65dbf6d012e2a888aca0e2 100644 (file)
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -1,10 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2018 Alexander Ilin.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes db kernel namespaces
-classes.tuple words sequences slots math accessors
-math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types db.private fry
-combinators.short-circuit db.errors ;
+USING: accessors assocs classes classes.tuple
+combinators.short-circuit continuations db db.errors db.types
+destructors kernel math.parser namespaces sequences sets words ;
 IN: db.tuples
 
 HOOK: create-sql-statement db-connection ( class -- object )
@@ -14,7 +13,7 @@ HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
 HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
 HOOK: <update-tuple-statement> db-connection ( class -- object )
 HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
-HOOK: <select-by-slots-statement> db-connection ( tuple class -- tuple )
+HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
 HOOK: <count-statement> db-connection ( query -- statement )
 HOOK: query>statement db-connection ( query -- statement )
 HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
@@ -29,40 +28,45 @@ SYMBOL: sql-counter
 GENERIC: eval-generator ( singleton -- object )
 
 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
-    rot class new [
+    rot class-of new [
         '[ slot-name>> _ set-slot-named ] 2each
     ] keep ;
 
+: query-tuples-each ( exemplar-tuple statement quot: ( tuple -- ) -- )
+    [ [ out-params>> ] keep query-results ] dip '[
+        [ sql-row-typed swap resulting-tuple @ ] 2with query-each
+    ] with-disposal ; inline
+
 : query-tuples ( exemplar-tuple statement -- seq )
-    [ out-params>> ] keep query-results [
-        [ sql-row-typed swap resulting-tuple ] with with query-map
-    ] with-disposal ;
- 
+    [ ] collector [ query-tuples-each ] dip { } like ;
+
 : query-modify-tuple ( tuple statement -- )
     [ query-results [ sql-row-typed ] with-disposal ] keep
-    out-params>> rot [
-        [ slot-name>> ] dip set-slot-named
-    ] curry 2each ;
+    out-params>> rot '[ slot-name>> _ set-slot-named ] 2each ;
 
 : with-disposals ( object quotation -- )
     over sequence? [
-        [ with-disposal ] curry each
+        over '[ _ dispose-each ] finally
     ] [
         with-disposal
     ] if ; inline
 
 : insert-db-assigned-statement ( tuple -- )
-    dup class
+    dup class-of
     db-connection get insert-statements>>
     [ <insert-db-assigned-statement> ] cache
     [ bind-tuple ] 2keep insert-tuple-set-key ;
 
 : insert-user-assigned-statement ( tuple -- )
-    dup class
+    dup class-of
     db-connection get insert-statements>>
     [ <insert-user-assigned-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
+: do-each-tuple ( exemplar-tuple statement quot: ( tuple -- ) -- tuples )
+    '[ [ bind-tuple ] [ _ query-tuples-each ] 2bi ] with-disposal
+    ; inline
+
 : do-select ( exemplar-tuple statement -- tuples )
     [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
 
@@ -73,9 +77,10 @@ PRIVATE>
 
 ! High level
 ERROR: no-slots-named class seq ;
-: check-columns ( class columns -- )
+
+: check-columns ( columns class -- )
     [ nip ] [
-        [ [ first ] map ]
+        [ keys ]
         [ all-slots [ name>> ] map ] bi* diff
     ] 2bi
     [ drop ] [ no-slots-named ] if-empty ;
@@ -115,34 +120,26 @@ ERROR: no-defined-persistent object ;
     drop-sql-statement [ execute-statement ] with-disposals ;
 
 : recreate-table ( class -- )
-    ensure-defined-persistent
-    [
-        '[
-            [
-                _ drop-sql-statement [ execute-statement ] with-disposals
-            ] ignore-table-missing
-        ] ignore-function-missing
-    ] [ create-table ] bi ;
+    [ '[ [ _ drop-table ] ignore-table-missing ] ignore-function-missing ]
+    [ create-table ] bi ;
 
 : ensure-table ( class -- )
-    ensure-defined-persistent
     '[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
 
 : ensure-tables ( classes -- ) [ ensure-table ] each ;
 
 : insert-tuple ( tuple -- )
-    dup class ensure-defined-persistent
-    db-columns find-primary-key db-assigned-id-spec?
+    dup class-of ensure-defined-persistent db-assigned?
     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 
 : update-tuple ( tuple -- )
-    dup class ensure-defined-persistent
+    dup class-of ensure-defined-persistent
     db-connection get update-statements>> [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : delete-tuples ( tuple -- )
     dup
-    dup class ensure-defined-persistent
+    dup class-of ensure-defined-persistent
     <delete-tuples-statement> [
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
@@ -152,9 +149,18 @@ ERROR: no-defined-persistent object ;
 
 : select-tuple ( query/tuple -- tuple/f )
     >query 1 >>limit [ tuple>> ] [ query>statement ] bi
-    do-select [ f ] [ first ] if-empty ;
+    do-select ?first ;
 
 : count-tuples ( query/tuple -- n )
     >query [ tuple>> ] [ <count-statement> ] bi do-count
-    dup length 1 =
-    [ first first string>number ] [ [ first string>number ] map ] if ;
+    [ first string>number ] map dup length 1 = [ first ] when ;
+
+: each-tuple ( query/tuple quot: ( tuple -- ) -- )
+    [ >query [ tuple>> ] [ query>statement ] bi ] dip do-each-tuple
+    ; inline
+
+: update-tuples ( query/tuple quot: ( tuple -- tuple'/f ) -- )
+    '[ @ [ update-tuple ] when* ] each-tuple ; inline
+
+: reject-tuples ( query/tuple quot: ( tuple -- ? ) -- )
+    '[ dup @ [ delete-tuples ] [ drop ] if ] each-tuple ; inline