some renaming

now adding an advice for marking a tuple dirty

bson/writer/writer.factor

@@ -4,7 +4,7 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors
 calendar fry io io.binary io.encodings io.encodings.binary
 io.encodings.utf8 io.streams.byte-array kernel math math.parser
 namespaces quotations sequences sequences.private serialize strings
-words ;
+words combinators.short-circuit ;
 
 
 IN: bson.writer
@@ -164,3 +164,6 @@ PRIVATE>
 : assoc>stream ( assoc -- )
     bson-write ; inline
 
+: mdb-special-value? ( value -- ? )
+   { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
+     [ oid? ] [ byte-array? ] } 1|| ;

mongodb/tuple/persistent/persistent.factor

@@ -1,10 +1,11 @@
-USING: accessors assocs classes fry kernel linked-assocs math mirrors
+USING: accessors assocs bson.constants combinators.short-circuit
-namespaces sequences strings vectors words bson.constants 
+constructors continuations fry kernel mirrors mongodb.tuple.collection
-continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ;
+mongodb.tuple.state namespaces sequences words bson.writer combinators
+hashtables linked-assocs ;
 
 IN: mongodb.tuple.persistent
 
-SYMBOL: mdb-store-list
+SYMBOLS: object-map ;
 
 GENERIC: tuple>assoc ( tuple -- assoc )
 
@@ -15,7 +16,7 @@ DEFER: assoc>tuple
 <PRIVATE
 
 : mdbinfo>tuple-class ( tuple-info -- class )
-    [ first ] keep second lookup ; inline
+   [ first ] keep second lookup ; inline
 
 : tuple-instance ( tuple-info -- instance )
     mdbinfo>tuple-class new ; inline 
@@ -27,7 +28,7 @@ DEFER: assoc>tuple
 : make-tuple ( assoc -- tuple )
    prepare-assoc>tuple
    '[ dup _ at assoc>tuple swap _ set-at ] each
-   [ set-persistent ] keep ; inline recursive
+   [ mark-persistent ] keep ; inline recursive
 
 : at+ ( value key assoc -- value )
     2dup key?
@@ -38,21 +39,43 @@ DEFER: assoc>tuple
     [ assoc? not ] [ drop f ] if  ; inline
 
 : add-storable ( assoc ns -- )
-   [ H{ } clone ] dip mdb-store-list get at+
+   [ H{ } clone ] dip object-map get at+
    [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
 
 : write-field? ( tuple key value -- ? )
-   [ [ 2drop ] dip not ] [ drop transient-slot? ] 3bi or not ; inline
+   pick mdb-persistent? [ 
+      { [ [ 2drop ] dip not ]
+        [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
+
+TUPLE: cond-value value quot ;
+
+CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
+
+: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
+   over needs-store?
+   [ over [ (( tuple -- assoc )) call-effect ] dip 
+     [ tuple-collection name>> ] keep
+     [ add-storable ] dip
+   ] [ drop ] if 
+   [ tuple-collection name>> ] [ _id>> ] bi <objref> ; inline
+
+: write-field ( value quot: ( tuple -- assoc ) -- value' )
+   <cond-value> {
+      { [ dup value>> mdb-special-value? ] [ value>> ]  }
+      { [ dup value>> mdb-persistent? ]
+        [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
+      { [ dup value>> data-tuple? ]
+        [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ]  }
+      { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
+        [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
+      [ value>> ]
+   } cond ; inline recursive
 
 : write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
-   swap dupd ! m t q q a 
+   swap ! m t q q a 
    '[ _ 2over write-field?
-      [ dup mdb-persistent?
+      [ _ write-field swap _ set-at ]
-        [ _ keep
+      [ 2drop ] if
-          [ tuple-collection ] keep
-          [ add-storable ] dip
-          [ tuple-collection ] [ _id>> ] bi <objref> ]
-        [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if
    ] assoc-each ; 
 
 : prepare-assoc ( tuple -- assoc mirror tuple assoc )
@@ -60,20 +83,21 @@ DEFER: assoc>tuple
 
 : ensure-mdb-info ( tuple -- tuple )    
    dup _id>> [ <objid> >>_id ] unless
-   [ set-persistent ] keep ; inline
+   [ mark-persistent ] keep ; inline
 
-: with-store-list ( quot: ( -- ) -- store-assoc )
+: with-object-map ( quot: ( -- ) -- store-assoc )
-   [ H{ } clone dup mdb-store-list ] dip with-variable ; inline
+   [ H{ } clone dup object-map ] dip with-variable ; inline
 
 : (tuple>assoc) ( tuple -- assoc )
    [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
-   over set-tuple-info ;
+   over set-tuple-info ; inline
 
 PRIVATE>
 
-GENERIC: tuple>storable ( tuple -- storable ) 
+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>storable ( mdb-persistent -- object-map )
+   '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
 
 M: mdb-persistent tuple>assoc ( tuple -- assoc )
    ensure-mdb-info (tuple>assoc) ;

mongodb/tuple/state/state.factor

@@ -1,4 +1,5 @@
-USING: classes kernel accessors sequences assocs mongodb.tuple.collection ;
+USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection
+advice words classes.tuple slots ;
 
 IN: mongodb.tuple.state
 
@@ -7,9 +8,13 @@ IN: mongodb.tuple.state
 CONSTANT: MDB_TUPLE_INFO       "_mfd_t_info"
 CONSTANT: MDB_DIRTY_FLAG       "d?"
 CONSTANT: MDB_PERSISTENT_FLAG  "p?"
+CONSTANT: MDB_DIRTY_ADVICE     "mdb-dirty-set"
 
 PRIVATE>
 
+: advised-with? ( name word loc -- ? )
+   word-prop key? ; inline
+
 : <tuple-info> ( tuple -- tuple-info )
     class V{ } clone tuck  
     [ [ name>> ] dip push ]
@@ -28,17 +33,35 @@ PRIVATE>
    dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
 
 : dirty? ( tuple -- ? )
-    MDB_DIRTY_FLAG tuple-meta at ;
+   [ MDB_DIRTY_FLAG ] dip tuple-meta at ;
 
-: set-dirty ( tuple -- )
+: mark-dirty ( tuple -- )
-    [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
+   [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
 
 : persistent? ( tuple -- ? )
-    MDB_PERSISTENT_FLAG tuple-meta at ;
+   [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ;
 
-: set-persistent ( tuple -- )
+: mark-persistent ( tuple -- )
-    [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ;
+   [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep
+   [ f MDB_DIRTY_FLAG ] dip set-at ;
 
 : needs-store? ( tuple -- ? )
-    [ persistent? not ] [ dirty? ] bi or ;
+   [ persistent? not ] [ dirty? ] bi or ;
 
+<PRIVATE
+
+: create-advice ( word -- )
+   MDB_DIRTY_ADVICE over after advised-with?
+   [ drop ]
+   [ [ [ dup mark-dirty ] MDB_DIRTY_ADVICE ] dip advise-after ] if ;
+
+: (annotate-writer) ( class name -- )
+   writer-word "methods" word-prop at
+   [ create-advice ] when* ;
+
+PRIVATE>
+
+: annotate-writers ( class -- )
+   dup all-slots [ name>> ] map
+   MDB_ADDON_SLOTS '[ _ memq? not ] filter
+   [ (annotate-writer) ] with each ;

mongodb/tuple/tuple.factor

@@ -1,7 +1,7 @@
 USING: accessors assocs classes.mixin classes.tuple
-classes.tuple.parser compiler.units fry kernel mongodb.driver
+classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
 mongodb.msg mongodb.tuple.collection mongodb.tuple.index
-mongodb.tuple.persistent mongodb.tuple.state sequences strings ;
+mongodb.tuple.persistent mongodb.tuple.state strings ;
 
 IN: mongodb.tuple
 
@@ -13,7 +13,8 @@ SYNTAX: MDBTUPLE:
 : 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 
+    [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
+    [ dup annotate-writers ] dip 
     set-slot-map ;
 
 : ensure-table ( class -- )
@@ -39,8 +40,10 @@ SYNTAX: MDBTUPLE:
 <PRIVATE
 
 GENERIC: id-selector ( object -- 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 ;