1 USING: accessors assocs bson.constants bson.writer combinators
2 combinators.short-circuit constructors continuations hashtables
3 kernel linked-assocs mirrors mongodb.tuple.collection
4 mongodb.tuple.state namespaces sequences words ;
5 IN: mongodb.tuple.persistent
9 GENERIC: tuple>assoc ( tuple -- assoc )
11 GENERIC: tuple>selector ( tuple -- selector )
17 : mdbinfo>tuple-class ( tuple-info -- class )
18 [ first ] keep second lookup-word ; inline
20 : tuple-instance ( tuple-info -- instance )
21 mdbinfo>tuple-class new ; inline
23 : prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
24 [ tuple-info tuple-instance dup
25 <mirror> [ keys ] keep ] keep swap ; inline
27 : make-tuple ( assoc -- tuple )
29 '[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive
31 : at+ ( value key assoc -- value )
33 [ at nip ] [ [ dup ] 2dip set-at ] if ; inline
35 : data-tuple? ( tuple -- ? )
37 [ assoc? not ] [ drop f ] if ; inline
39 : add-storable ( assoc ns toid -- )
40 [ [ H{ } clone ] dip object-map get at+ ] dip
43 : write-field? ( tuple key value -- ? )
44 pick mdb-persistent? [
46 [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
48 TUPLE: cond-value value quot ;
50 CONSTRUCTOR: <cond-value> cond-value ( value quot -- cond-value ) ;
52 : write-mdb-persistent ( value quot -- value' )
53 over [ call( tuple -- assoc ) ] dip
54 [ [ tuple-collection name>> ] [ >toid ] bi ] keep
56 [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
58 : write-field ( value quot -- value' )
60 { [ dup value>> mdb-special-value? ] [ value>> ] }
61 { [ dup value>> mdb-persistent? ]
62 [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
63 { [ dup value>> data-tuple? ]
64 [ [ value>> ] [ quot>> ] bi ( tuple -- assoc ) call-effect ] }
65 { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
66 [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
70 : write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
72 '[ _ 2over write-field?
73 [ _ write-field swap _ set-at ]
77 : prepare-assoc ( tuple -- assoc mirror tuple assoc )
78 H{ } clone swap [ <mirror> ] keep pick ; inline
80 : with-object-map ( quot: ( -- ) -- store-assoc )
81 [ H{ } clone dup object-map ] dip with-variable ; inline
83 : (tuple>assoc) ( tuple -- assoc )
84 [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
85 over set-tuple-info ; inline
89 GENERIC: tuple>storable ( tuple -- storable )
91 : ensure-oid ( tuple -- tuple )
92 dup id>> [ <oid> >>id ] unless ; inline
94 M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
95 '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
97 M: mdb-persistent tuple>assoc ( tuple -- assoc )
98 ensure-oid (tuple>assoc) ;
100 M: tuple tuple>assoc ( tuple -- assoc )
103 M: tuple tuple>selector ( tuple -- assoc )
104 prepare-assoc [ tuple>selector ] write-tuple-fields ;
106 : assoc>tuple ( assoc -- tuple )
108 [ dup tuple-info? [ make-tuple ] when ] ignore-errors
109 ] when ; inline recursive