checkpoint tuple integration

bson/constants/constants.factor

@@ -1,4 +1,4 @@
-USING: accessors kernel math parser sequences strings uuid ;
+USING: accessors constructors kernel strings uuid ;
 
 IN: bson.constants
 
@@ -11,6 +11,8 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ;
 
 TUPLE: objref ns objid ;
 
+CONSTRUCTOR: objref ( ns objid -- objref ) ;
+
 TUPLE: mdbregexp { regexp string } { options string } ;
 
 : <mdbregexp> ( string -- mdbregexp )
@@ -18,7 +20,7 @@ TUPLE: mdbregexp { regexp string } { options string } ;
 
 
 CONSTANT: MDB_OID_FIELD "_id"
-CONSTANT: MDB_INTERNAL_FIELD "_mdb_"
+CONSTANT: MDB_META_FIELD "_mfd"
 
 CONSTANT: T_EOO  0  
 CONSTANT: T_Double  1  

bson/writer/writer.factor

@@ -149,7 +149,7 @@ M: sequence bson-write ( array -- )
     [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline
 
 : skip-field? ( name -- boolean )
-    { "_id" "_mdb" } member? ; inline
+    { "_id" "_mfd" } member? ; inline
 
 M: assoc bson-write ( assoc -- )
     '[ _  [ write-oid ] keep

mongodb/driver/driver.factor

@@ -20,7 +20,8 @@ TUPLE: mdb-collection
 { size integer initial: -1 }
 { max integer initial: -1 } ;
 
-CONSTRUCTOR: mdb-collection ( name -- collection ) ;
+: <mdb-collection> ( name -- collection )
+    [ mdb-collection new ] dip >>name ; inline
 
 CONSTANT: MDB-GENERAL-ERROR 1
 
@@ -73,6 +74,10 @@ SYNTAX: r/ ( token -- mdbregexp )
       [ >>mdb-stream ] prepose
       with-disposal ] with-scope ; inline
   
+: build-id-selector ( assoc -- selector )
+    [ MDB_OID_FIELD swap at ] keep
+    H{ } clone [ set-at ] keep ;
+
 <PRIVATE
 
 : index-collection ( -- ns )
@@ -161,7 +166,8 @@ M: mdb-collection create-collection ( mdb-collection -- )
              [ [ size>> "size" ] dip set-at ]
              [ [ max>> "max" ] dip set-at ] 2tri ] when
         ] 2bi
-    ] keep <mdb-query-msg> 1 >>return# send-query-plain objects>> first check-ok
+    ] keep <mdb-query-msg> 1 >>return# send-query-plain
+    objects>> first check-ok
     [ "could not create collection" throw ] unless ;
 
 : load-collection-list ( -- collection-list )
@@ -238,7 +244,7 @@ GENERIC: find-one ( mdb-query -- result/f )
 M: mdb-query-msg find-one
     1 >>return# send-query-plain objects>> [ first ] [ f ] if* ;
 
-GENERIC: count ( collection query -- result )
+GENERIC: count ( collection selector -- result )
 M: assoc count
     [ "count" H{ } clone [ set-at ] keep ] dip
     [ over [ "query" ] dip set-at ] when*

mongodb/tuple/collection/collection.factor

@@ -0,0 +1,90 @@
+
+USING: accessors arrays assocs bson.constants classes classes.tuple
+continuations fry kernel mongodb.driver sequences
+vectors words ;
+
+IN: mongodb.tuple.collection
+
+MIXIN: mdb-persistent
+
+SLOT: _id
+SLOT: _mfd
+
+TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
+
+GENERIC: tuple-collection ( object -- mdb-collection )
+
+GENERIC: mdb-slot-list  ( tuple -- string )
+
+<PRIVATE
+
+CONSTANT: MDB_COLLECTION     "_mdb_col"
+CONSTANT: MDB_SLOTDEF_LIST   "_mdb_slot_list"
+CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
+
+: (mdb-collection) ( class -- mdb-collection )     
+    dup MDB_COLLECTION word-prop
+    [ nip ]
+    [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
+
+: (mdb-slot-list) ( class -- slot-defs )
+    superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine  ; inline 
+
+: split-optl ( seq -- key options )
+    [ first ] [ rest ] bi ; inline
+
+: opt>assoc ( seq -- assoc )
+    [ dup assoc?
+      [ 1array { "" } append ] unless ] map ;
+
+: optl>map ( seq -- map )
+    H{ } clone tuck
+    '[ split-optl opt>assoc swap _ set-at ] each ; inline
+
+PRIVATE>
+
+: MDB_ADDON_SLOTS ( -- slots )
+    { } [ MDB_OID_FIELD MDB_META_FIELD ] with-datastack ; inline
+
+: link-class ( collection class -- )
+    over classes>>
+    [ 2dup member? [ 2drop ] [ push ] if ]
+    [ 1vector >>classes ] if* drop ; inline
+
+: link-collection ( class collection -- )
+    [ swap link-class ]
+    [ MDB_COLLECTION set-word-prop ] 2bi ; inline
+
+: mdb-check-slots ( superclass slots -- superclass slots )
+    over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
+    [  ] [ MDB_ADDON_SLOTS prepend ] if ; inline
+
+: set-slot-options ( class options -- )
+    '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep
+    dup tuple-collection link-collection ; inline
+  
+M: tuple-class tuple-collection ( tuple -- mdb-collection )
+    (mdb-collection) ;
+ 
+M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
+    class (mdb-collection) ;
+ 
+M: mdb-persistent mdb-slot-list ( tuple -- string )
+    class (mdb-slot-list) ;
+
+M: tuple-class mdb-slot-list ( class -- assoc )
+    (mdb-slot-list) ;
+
+M: mdb-collection mdb-slot-list ( collection -- assoc )
+    classes>> [ mdb-slot-list ] map assoc-combine ;
+
+: collection-map ( -- assoc )
+    MDB_COLLECTION_MAP mdb-persistent word-prop
+    [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
+      [ set-word-prop ] keep ] unless* ; inline
+  
+: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
+    collection-map [ ] [ key? ] 2bi 
+    [ at ] [ [ mdb-tuple-collection new dup ] 2dip 
+             [ [ >>name ] keep ] dip set-at ] if ; inline
+

mongodb/tuple/index/index.factor

@@ -0,0 +1,54 @@
+USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
+mongodb.tuple.collection combinators mongodb.tuple.collection ; 
+
+IN: mongodb.tuple.index
+
+TUPLE: tuple-index name spec ;
+
+SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
+
+<PRIVATE
+
+: index-type ( type -- name )
+    { { +fieldindex+ [ "field" ] }
+      { +deepindex+ [ "deep" ] }
+      { +compoundindex+ [ "compound" ] } } case ;
+  
+: index-name ( slot index-spec -- name )
+    [ first index-type ] keep
+    rest "-" join
+    "%s-%s-%s-Idx" sprintf ;
+
+: build-index ( element slot -- assoc )
+    swap [ <linked-hash> ] 2dip
+    [ rest ] keep first ! assoc slot options itype
+    { { +fieldindex+ [ drop [ 1 ] dip pick set-at  ] }
+      { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] }
+      { +compoundindex+ [
+          2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options
+          over '[ _ [ 1 ] 2dip set-at ] each ] }
+    } case ;
+
+: build-index-seq ( slot optlist -- index-seq )
+    [ V{ } clone ] 2dip pick  ! v{} slot optl v{}      
+    [ swap ] dip  ! v{} optl slot v{ }
+    '[ _ tuple-index new ! element slot exemplar 
+       2over swap index-name >>name  ! element slot clone
+       [ build-index ] dip swap >>spec _ push
+    ] each ;
+
+: is-index-declaration? ( entry -- ? )
+    first
+    { { +fieldindex+ [ t ] }
+      { +compoundindex+ [ t ] }
+      { +deepindex+ [ t ] }
+      [ drop f ] } case ;
+
+PRIVATE>
+
+: tuple-index-list ( mdb-collection/class -- seq )
+    mdb-slot-list V{ } clone tuck
+    '[ [ is-index-declaration? ] filter
+       build-index-seq _ push 
+    ] assoc-each flatten ;
+

mongodb/tuple/persistent/persistent.factor

@@ -0,0 +1,92 @@
+USING: accessors assocs classes fry kernel linked-assocs math mirrors
+namespaces sequences strings vectors words bson.constants 
+continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ;
+
+IN: mongodb.tuple.persistent
+
+SYMBOL: mdb-store-list
+
+GENERIC: tuple>assoc ( tuple -- assoc )
+
+GENERIC: tuple>selector ( tuple -- selector )
+
+DEFER: assoc>tuple
+DEFER: mdb-persistent?
+
+<PRIVATE
+
+: mdbinfo>tuple-class ( tuple-info -- class )
+    [ first ] keep second lookup ; inline
+
+: tuple-instance ( tuple-info -- instance )
+    mdbinfo>tuple-class new ; inline 
+
+: [keys>tuple] ( mirror assoc -- quot: ( elt -- ) )
+   '[ dup _ at assoc>tuple swap _ set-at ] ;  
+
+: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
+   [ tuple-info tuple-instance dup
+     <mirror> [ keys ] keep ] keep swap ; inline
+
+: make-tuple ( assoc -- tuple )
+   prepare-assoc>tuple [keys>tuple] each
+   [ set-persistent ] keep ; inline 
+
+: at+ ( value key assoc -- value )
+    2dup key?
+    [ at nip ] [ [ dup ] 2dip set-at ] if ; inline
+
+: data-tuple? ( tuple -- ? )
+    dup tuple?
+    [ assoc? not ] [ drop f ] if  ; inline
+
+: add-storable ( assoc ns -- )
+   [ H{ } clone ] dip mdb-store-list get at+
+   [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
+ 
+: write-tuple-fields ( mirror assoc conv-quot -- )
+   swap [ dup ] dip ! m a a q
+   '[ [ dup mdb-persistent?
+        [ _ keep
+          [ tuple-collection ] keep
+          [ add-storable ] dip
+          [ tuple-collection ] [ _id>> ] bi <objref> ]
+        [ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if*
+   ] assoc-each ; 
+
+: prepare-assoc ( tuple -- assoc mirror assoc )
+   <mirror> H{ } clone tuck ; inline
+
+: ensure-mdb-info ( tuple -- tuple )    
+   dup _id>> [ <objid> >>_id ] unless
+   [ set-persistent ] keep ; inline
+
+: with-store-list ( quot: ( -- ) -- store-assoc )
+   [ H{ } clone dup mdb-store-list ] dip with-variable ; inline
+
+: (tuple>assoc) ( tuple -- assoc )
+   [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
+   over set-tuple-info ;
+
+PRIVATE>
+
+GENERIC: tuple>storable ( tuple -- storable ) 
+M: mdb-persistent tuple>storable ( mdb-persistent -- store-list )
+   '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline
+
+M: mdb-persistent tuple>assoc ( tuple -- assoc )
+   ensure-mdb-info (tuple>assoc) ;
+
+M: tuple tuple>assoc ( tuple -- assoc )
+   (tuple>assoc) ;
+
+M: tuple tuple>selector ( tuple -- assoc )
+    prepare-assoc [ tuple>selector ] write-tuple-fields ;
+
+: assoc>tuple ( assoc -- tuple )
+    dup assoc?
+    [ [ dup tuple-info?
+        [ make-tuple ]
+        [ ] if ] [ drop ] recover
+    ] [ ] if ; inline
+

mongodb/tuple/state/state.factor

@@ -0,0 +1,44 @@
+USING: classes kernel accessors sequences assocs mongodb.tuple.collection ;
+
+IN: mongodb.tuple.state
+
+<PRIVATE
+
+CONSTANT: MDB_TUPLE_INFO       "_mfd_t_info"
+CONSTANT: MDB_DIRTY_FLAG       "d?"
+CONSTANT: MDB_PERSISTENT_FLAG  "p?"
+
+PRIVATE>
+
+: <tuple-info> ( tuple -- tuple-info )
+    class V{ } clone tuck  
+    [ [ name>> ] dip push ]
+    [ [ vocabulary>> ] dip push ] 2bi ; inline
+
+: tuple-info ( assoc -- tuple-info )
+    [ MDB_TUPLE_INFO ] dip at ; inline
+
+: set-tuple-info ( tuple assoc -- )
+   [ <tuple-info> MDB_TUPLE_INFO ] dip set-at ; inline
+
+: tuple-info? ( assoc -- ? )
+   [ MDB_TUPLE_INFO ] dip key? ;
+
+: tuple-meta ( tuple -- assoc )
+   dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
+
+: dirty? ( tuple -- ? )
+   MDB_DIRTY_FLAG tuple-meta at ;
+
+: set-dirty ( tuple -- )
+   t MDB_DIRTY_FLAG tuple-meta set-at ;
+
+: persistent? ( tuple -- ? )
+   MDB_PERSISTENT_FLAG tuple-meta at ;
+
+: set-persistent ( tuple -- )
+   t MDB_PERSISTENT_FLAG tuple-meta set-at ;
+
+: needs-store? ( tuple -- ? )
+   [ persistent? not ] [ dirty? ] bi or ;
+

mongodb/tuple/tuple.factor

@@ -0,0 +1,83 @@
+USING: accessors assocs classes classes.mixin classes.tuple vectors math
+classes.tuple.parser formatting generalizations kernel sequences fry combinators
+linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants
+prettyprint strings compiler.units slots tools.walker words arrays ;
+
+IN: mongodb.tuple
+
+USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection
+mongodb.tuple.index mongodb.msg ; 
+
+SYNTAX: MDBTUPLE:
+    parse-tuple-definition
+    mdb-check-slots
+    define-tuple-class ; 
+
+: define-persistent ( class collection options -- )
+    [ [ dup ] dip link-collection ] dip ! cl options
+    [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip 
+    set-slot-options ;
+
+: ensure-table ( class -- )
+    tuple-collection
+    [ create-collection ]
+    [ [ tuple-index-list ] keep
+      '[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each
+    ] bi ;
+
+: ensure-tables ( classes -- )
+    [ ensure-table ] each ; 
+
+: drop-table ( class -- )
+      tuple-collection
+      [ [ tuple-index-list ] keep
+        '[ _ swap name>> drop-index ] each ]
+      [ name>> drop-collection ] bi ;
+
+: recreate-table ( class -- )
+    [ drop-table ] 
+    [ ensure-table ] bi ;
+
+<PRIVATE
+
+GENERIC: id-selector ( object -- selector )
+M: objid id-selector ( objid -- selector )
+   "_id" H{ } clone [ set-at ] keep ; inline
+M: mdb-persistent id-selector ( mdb-persistent -- selector )
+   id>> id-selector ;
+
+: (save-tuples) ( collection assoc -- )
+   swap '[ [ _ ] 2dip
+           [ id-selector ] dip
+           <update> update ] assoc-each ; inline
+PRIVATE>
+ 
+: save-tuple ( tuple -- )
+   tuple>assoc [ (save-tuples) ] assoc-each ;
+ 
+: update-tuple ( tuple -- )
+   save-tuple ;
+
+: insert-tuple ( tuple -- )
+   save-tuple ;
+
+: delete-tuple ( tuple -- )
+   dup persistent?
+   [ [ tuple-collection name>> ] keep
+     id-selector delete ] [ drop ] if ;
+
+: tuple>query ( tuple -- query )
+   [ tuple-collection name>> ] keep
+   tuple>selector <query> ;
+
+: select-tuple ( tuple/query -- tuple/f )
+   dup mdb-query-msg? [ ] [ tuple>query ] if
+   find-one [ assoc>tuple ] [ f ] if* ;
+
+: select-tuples ( tuple/query -- cursor tuples/f )
+   dup mdb-query-msg? [ ] [ tuple>query ] if
+   find [ assoc>tuple ] map ;
+
+: count-tuples ( tuple/query -- n )
+   dup mdb-query-msg? [ tuple>query ] unless
+   [ collection>> ] [ query>> ] bi count ;