-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 ;
+USING: accessors assocs bson.constants combinators.short-circuit
+constructors continuations fry kernel mirrors mongodb.tuple.collection
+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 )
<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
: 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?
[ 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?
- [ _ keep
- [ tuple-collection ] keep
- [ add-storable ] dip
- [ tuple-collection ] [ _id>> ] bi <objref> ]
- [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if
+ [ _ write-field swap _ set-at ]
+ [ 2drop ] if
] assoc-each ;
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
: ensure-mdb-info ( tuple -- tuple )
dup _id>> [ <objid> >>_id ] unless
- [ set-persistent ] keep ; inline
+ [ mark-persistent ] keep ; inline
-: with-store-list ( quot: ( -- ) -- store-assoc )
- [ H{ } clone dup mdb-store-list ] dip with-variable ; inline
+: with-object-map ( quot: ( -- ) -- store-assoc )
+ [ 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 )
-M: mdb-persistent tuple>storable ( mdb-persistent -- store-list )
- '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline
+GENERIC: tuple>storable ( tuple -- storable )
+
+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) ;
-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
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 ]
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 -- )
- [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
+: mark-dirty ( tuple -- )
+ [ 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 -- )
- [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ;
+: mark-persistent ( tuple -- )
+ [ 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 ;
\ No newline at end of file
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
: 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 -- )
<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 ;