1 USING: accessors assocs bson.constants combinators.short-circuit
2 constructors continuations fry kernel mirrors mongodb.tuple.collection
3 mongodb.tuple.state namespaces sequences words bson.writer combinators
4 hashtables linked-assocs ;
6 IN: mongodb.tuple.persistent
10 GENERIC: tuple>assoc ( tuple -- assoc )
12 GENERIC: tuple>selector ( tuple -- selector )
18 : mdbinfo>tuple-class ( tuple-info -- class )
19 [ first ] keep second lookup-word ; inline
21 : tuple-instance ( tuple-info -- instance )
22 mdbinfo>tuple-class new ; inline
24 : prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
25 [ tuple-info tuple-instance dup
26 <mirror> [ keys ] keep ] keep swap ; inline
28 : make-tuple ( assoc -- tuple )
30 '[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive
32 : at+ ( value key assoc -- value )
34 [ at nip ] [ [ dup ] 2dip set-at ] if ; inline
36 : data-tuple? ( tuple -- ? )
38 [ assoc? not ] [ drop f ] if ; inline
40 : add-storable ( assoc ns toid -- )
41 [ [ H{ } clone ] dip object-map get at+ ] dip
44 : write-field? ( tuple key value -- ? )
45 pick mdb-persistent? [
46 { [ [ 2drop ] dip not ]
47 [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
49 TUPLE: cond-value value quot ;
51 CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
53 : write-mdb-persistent ( value quot -- value' )
54 over [ call( tuple -- assoc ) ] dip
55 [ [ tuple-collection name>> ] [ >toid ] bi ] keep
57 [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
59 : write-field ( value quot -- value' )
61 { [ dup value>> mdb-special-value? ] [ value>> ] }
62 { [ dup value>> mdb-persistent? ]
63 [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
64 { [ dup value>> data-tuple? ]
65 [ [ value>> ] [ quot>> ] bi ( tuple -- assoc ) call-effect ] }
66 { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
67 [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
71 : write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
73 '[ _ 2over write-field?
74 [ _ write-field swap _ set-at ]
78 : prepare-assoc ( tuple -- assoc mirror tuple assoc )
79 H{ } clone swap [ <mirror> ] keep pick ; inline
81 : with-object-map ( quot: ( -- ) -- store-assoc )
82 [ H{ } clone dup object-map ] dip with-variable ; inline
84 : (tuple>assoc) ( tuple -- assoc )
85 [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
86 over set-tuple-info ; inline
90 GENERIC: tuple>storable ( tuple -- storable )
92 : ensure-oid ( tuple -- tuple )
93 dup id>> [ <oid> >>id ] unless ; inline
95 M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
96 '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
98 M: mdb-persistent tuple>assoc ( tuple -- assoc )
99 ensure-oid (tuple>assoc) ;
101 M: tuple tuple>assoc ( tuple -- assoc )
104 M: tuple tuple>selector ( tuple -- assoc )
105 prepare-assoc [ tuple>selector ] write-tuple-fields ;
107 : assoc>tuple ( assoc -- tuple )
111 [ ] if ] [ drop ] recover
112 ] [ ] if ; inline recursive