another checkpoint - tuple integration seems to work

bson/constants/constants.factor

@@ -2,10 +2,8 @@ USING: accessors constructors kernel strings uuid ;
 
 IN: bson.constants
 
-TUPLE: objid id ;
-
 : <objid> ( -- objid )
-   objid new uuid1 >>id ; inline
+   uuid1 ; inline
 
 TUPLE: oid { a initial: 0 } { b initial: 0 } ;
 

bson/reader/reader.factor

@@ -186,11 +186,6 @@ M: bson-binary-custom element-binary-read ( size type -- dbref )
     read-cstring
     read-cstring objref boa ;
 
-M: bson-binary-uuid element-binary-read ( size type -- object )
-    2drop
-    read-cstring
-    objid boa ;
-
 M: bson-binary-bytes element-binary-read ( size type -- bytes )
     drop read ;
 

bson/writer/writer.factor

@@ -77,7 +77,6 @@ M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
 M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
 
 M: oid bson-type? ( word -- type ) drop T_OID ;
-M: objid bson-type? ( objid -- type ) drop T_Binary ;
 M: objref bson-type? ( objref -- type ) drop T_Binary ;
 M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
 M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
@@ -126,16 +125,11 @@ M: quotation bson-write ( quotation -- )
 M: oid bson-write ( oid -- )
     [ a>> write-longlong ] [ b>> write-int32 ] bi ;
 
-M: objid bson-write ( oid -- )
-    id>> [ binary ] dip '[ _ write-cstring ] with-byte-writer
-    [ length write-int32 ] keep
-    T_Binary_UUID write-byte write ;
-
 M: objref bson-write ( objref -- )
     [ binary ] dip
     '[ _
        [ ns>> write-cstring ]
-       [ objid>> id>> write-cstring ] bi ] with-byte-writer
+       [ objid>> write-cstring ] bi ] with-byte-writer
     [ length write-int32 ] keep
     T_Binary_Custom write-byte write ;
        

mongodb/driver/driver.factor

@@ -195,6 +195,7 @@ MEMO: reserved-namespace? ( name -- ? )
 PRIVATE>
 
 MEMO: ensure-collection ( collection -- fq-collection )
+    dup mdb-collection? [ name>> ] when
     "." split1 over mdb name>> =
     [ nip ] [ drop ] if
     [ ] [ reserved-namespace? ] bi

mongodb/tuple/collection/collection.factor

@@ -1,10 +1,16 @@
 
 USING: accessors arrays assocs bson.constants classes classes.tuple
-continuations fry kernel mongodb.driver sequences
+combinators continuations fry kernel mongodb.driver sequences strings
 vectors words ;
 
+IN: mongodb.tuple
+
+SINGLETONS: +transient+ +load+ ;
+
 IN: mongodb.tuple.collection
 
+FROM: mongodb.tuple => +transient+ +load+ ;
+
 MIXIN: mdb-persistent
 
 SLOT: _id
@@ -14,7 +20,7 @@ TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
 
 GENERIC: tuple-collection ( object -- mdb-collection )
 
-GENERIC: mdb-slot-list  ( tuple -- string )
+GENERIC: mdb-slot-map  ( tuple -- string )
 
 <PRIVATE
 
@@ -27,7 +33,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
     [ nip ]
     [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
 
-: (mdb-slot-list) ( class -- slot-defs )
+: (mdb-slot-map) ( class -- slot-defs )
     superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine  ; inline 
 
 : split-optl ( seq -- key options )
@@ -59,8 +65,8 @@ PRIVATE>
     over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
     [  ] [ MDB_ADDON_SLOTS prepend ] if ; inline
 
-: set-slot-options ( class options -- )
+: set-slot-map ( class options -- )
-    '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep
+    '[ _ optl>map MDB_SLOTDEF_LIST set-word-prop ] keep
     dup tuple-collection link-collection ; inline
   
 M: tuple-class tuple-collection ( tuple -- mdb-collection )
@@ -69,22 +75,44 @@ M: tuple-class tuple-collection ( tuple -- mdb-collection )
 M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
     class (mdb-collection) ;
  
-M: mdb-persistent mdb-slot-list ( tuple -- string )
+M: mdb-persistent mdb-slot-map ( tuple -- string )
-    class (mdb-slot-list) ;
+    class (mdb-slot-map) ;
 
-M: tuple-class mdb-slot-list ( class -- assoc )
+M: tuple-class mdb-slot-map ( class -- assoc )
-    (mdb-slot-list) ;
+    (mdb-slot-map) ;
 
-M: mdb-collection mdb-slot-list ( collection -- assoc )
+M: mdb-collection mdb-slot-map ( collection -- assoc )
-    classes>> [ mdb-slot-list ] map assoc-combine ;
+    classes>> [ mdb-slot-map ] map assoc-combine ;
+
+<PRIVATE
 
 : collection-map ( -- assoc )
-    MDB_COLLECTION_MAP mdb-persistent word-prop
+    mdb-persistent MDB_COLLECTION_MAP word-prop
     [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
       [ set-word-prop ] keep ] unless* ; inline
+
+: slot-option? ( tuple slot option -- ? )
+    [ swap mdb-slot-map at ] dip
+    '[ _ swap key? ] [ f ] if* ;
   
-: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
+PRIVATE>
+
+GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
+M: string <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
+M: mdb-tuple-collection <mdb-tuple-collection> ( mdb-tuple-collection -- mdb-tuple-collection ) ;
+M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collection )
+    [ name>> <mdb-tuple-collection> ] keep
+    {
+        [ capped>> >>capped ]
+        [ size>> >>size ]
+        [ max>> >>max ]
+    } cleave ;
 
+: transient-slot? ( tuple slot -- ? )
+    +transient+ slot-option? ;
+
+: load-slot? ( tuple slot -- ? )
+    +load+ slot-option? ;

mongodb/tuple/index/index.factor

@@ -1,11 +1,15 @@
 USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
 mongodb.tuple.collection combinators mongodb.tuple.collection ; 
 
+IN: mongodb.tuple
+
+SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
+
 IN: mongodb.tuple.index
 
-TUPLE: tuple-index name spec ;
+FROM: mongodb.tuple => +fieldindex+ +compoundindex+ +deepindex+ ;
 
-SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
+TUPLE: tuple-index name spec ;
 
 <PRIVATE
 
@@ -47,7 +51,7 @@ SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
 PRIVATE>
 
 : tuple-index-list ( mdb-collection/class -- seq )
-    mdb-slot-list V{ } clone tuck
+    mdb-slot-map V{ } clone tuck
     '[ [ is-index-declaration? ] filter
        build-index-seq _ push 
     ] assoc-each flatten ;

mongodb/tuple/persistent/persistent.factor

@@ -11,7 +11,6 @@ GENERIC: tuple>assoc ( tuple -- assoc )
 GENERIC: tuple>selector ( tuple -- selector )
 
 DEFER: assoc>tuple
-DEFER: mdb-persistent?
 
 <PRIVATE
 
@@ -41,19 +40,23 @@ DEFER: mdb-persistent?
 : 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 -- )
+: write-field? ( tuple key value -- ? )
-   swap [ dup ] dip ! m a a q
+   [ [ 2drop ] dip not ] [ drop transient-slot? ] 3bi or not ; inline
-   '[ [ dup mdb-persistent?
+
+: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
+   swap dupd ! m t q q a 
+   '[ _ 2over write-field?
+      [ dup mdb-persistent?
         [ _ keep
           [ tuple-collection ] keep
           [ add-storable ] dip
           [ tuple-collection ] [ _id>> ] bi <objref> ]
-        [ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if*
+        [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if
    ] assoc-each ; 
 
-: prepare-assoc ( tuple -- assoc mirror assoc )
+: prepare-assoc ( tuple -- assoc mirror tuple assoc )
-   <mirror> H{ } clone tuck ; inline
+   H{ } clone swap [ <mirror> ] keep pick ; inline
 
 : ensure-mdb-info ( tuple -- tuple )    
    dup _id>> [ <objid> >>_id ] unless

mongodb/tuple/state/state.factor

@@ -28,17 +28,17 @@ PRIVATE>
    dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
 
 : dirty? ( tuple -- ? )
-   MDB_DIRTY_FLAG tuple-meta at ;
+    MDB_DIRTY_FLAG tuple-meta at ;
 
 : set-dirty ( tuple -- )
-   t MDB_DIRTY_FLAG tuple-meta set-at ;
+    [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
 
 : persistent? ( tuple -- ? )
-   MDB_PERSISTENT_FLAG tuple-meta at ;
+    MDB_PERSISTENT_FLAG tuple-meta at ;
 
 : set-persistent ( tuple -- )
-   t MDB_PERSISTENT_FLAG tuple-meta set-at ;
+    [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ;
 
 : needs-store? ( tuple -- ? )
-   [ persistent? not ] [ dirty? ] bi or ;
+    [ persistent? not ] [ dirty? ] bi or ;
 

mongodb/tuple/tuple.factor

@@ -1,28 +1,26 @@
-USING: accessors assocs classes classes.mixin classes.tuple vectors math
+USING: accessors assocs classes.mixin classes.tuple
-classes.tuple.parser formatting generalizations kernel sequences fry combinators
+classes.tuple.parser compiler.units fry kernel mongodb.driver
-linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants
+mongodb.msg mongodb.tuple.collection mongodb.tuple.index
-prettyprint strings compiler.units slots tools.walker words arrays ;
+mongodb.tuple.persistent mongodb.tuple.state sequences strings ;
 
 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 -- )
+    [ <mdb-tuple-collection> ] dip
     [ [ dup ] dip link-collection ] dip ! cl options
     [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip 
-    set-slot-options ;
+    set-slot-map ;
 
 : ensure-table ( class -- )
     tuple-collection
     [ create-collection ]
     [ [ tuple-index-list ] keep
-      '[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each
+      '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each
     ] bi ;
 
 : ensure-tables ( classes -- )
@@ -31,7 +29,7 @@ SYNTAX: MDBTUPLE:
 : drop-table ( class -- )
       tuple-collection
       [ [ tuple-index-list ] keep
-        '[ _ swap name>> drop-index ] each ]
+        '[ _ name>> swap name>> drop-index ] each ]
       [ name>> drop-collection ] bi ;
 
 : recreate-table ( class -- )
@@ -41,19 +39,19 @@ SYNTAX: MDBTUPLE:
 <PRIVATE
 
 GENERIC: id-selector ( object -- selector )
-M: objid id-selector ( objid -- selector )
+M: string id-selector ( objid -- selector )
    "_id" H{ } clone [ set-at ] keep ; inline
 M: mdb-persistent id-selector ( mdb-persistent -- selector )
-   id>> id-selector ;
+   _id>> id-selector ;
 
 : (save-tuples) ( collection assoc -- )
    swap '[ [ _ ] 2dip
            [ id-selector ] dip
-           <update> update ] assoc-each ; inline
+           <update> >upsert update ] assoc-each ; inline
 PRIVATE>
  
 : save-tuple ( tuple -- )
-   tuple>assoc [ (save-tuples) ] assoc-each ;
+   tuple>storable [ (save-tuples) ] assoc-each ;
  
 : update-tuple ( tuple -- )
    save-tuple ;