1 USING: accessors arrays assocs bson.constants classes
2 classes.tuple combinators constructors hashtables kernel
3 literals mongodb.driver mongodb.tuple sequences slots strings
6 ! XXX: This is weird, two IN: forms
9 SINGLETONS: +transient+ +load+ +user-defined-key+ ;
11 : <tuple-index> ( name key -- index-spec )
12 index-spec new swap >>key swap >>name ;
14 IN: mongodb.tuple.collection
16 TUPLE: toid key value ;
18 CONSTRUCTOR: <toid> toid ( value key -- toid ) ;
20 FROM: mongodb.tuple => +transient+ +load+ <tuple-index> ;
30 CONSTANT: MDB_COLLECTION "mongodb_collection"
31 CONSTANT: MDB_SLOTDEF_MAP "mongodb_slot_map"
32 CONSTANT: MDB_INDEX_MAP "mongodb_index_map"
33 CONSTANT: MDB_USER_KEY "mongodb_user_key"
34 CONSTANT: MDB_COLLECTION_MAP "mongodb_collection_map"
36 MEMO: id-slot ( class -- slot )
37 MDB_USER_KEY word-prop
38 dup [ drop "_id" ] unless ;
42 : >toid ( object -- toid )
43 [ id>> ] [ class-of id-slot ] bi <toid> ;
45 M: mdb-persistent id>> ( object -- id )
46 dup class-of id-slot reader-word execute( object -- id ) ;
48 M: mdb-persistent id<< ( object value -- )
49 over class-of id-slot writer-word execute( object value -- ) ;
53 TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
55 GENERIC: tuple-collection ( object -- mdb-collection )
57 GENERIC: mdb-slot-map ( tuple -- assoc )
59 GENERIC: mdb-index-map ( tuple -- sequence )
64 : (mdb-collection) ( class -- mdb-collection )
65 dup MDB_COLLECTION word-prop
67 [ superclass-of [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
69 : (mdb-slot-map) ( class -- slot-map )
70 superclasses-of [ MDB_SLOTDEF_MAP word-prop ] map assoc-union-all ; inline
72 : (mdb-index-map) ( class -- index-map )
73 superclasses-of [ MDB_INDEX_MAP word-prop ] map assoc-union-all ; inline
75 : split-optl ( seq -- key options )
76 [ first ] [ rest ] bi ; inline
78 : optl>map ( seq -- map )
79 [ H{ } clone ] dip over
80 '[ split-optl swap _ set-at ] each ; inline
82 : index-list>map ( seq -- map )
83 [ H{ } clone ] dip over
84 '[ dup name>> _ set-at ] each ; inline
86 : user-defined-key ( map -- key value ? )
87 [ nip [ +user-defined-key+ ] dip member? ] assoc-find ; inline
89 : user-defined-key-index ( class -- assoc )
90 mdb-slot-map user-defined-key
91 [ drop [ "user-defined-key-index" 1 ] dip
92 associate <tuple-index> t >>unique?
93 [ ] [ name>> ] bi associate
94 ] [ 2drop H{ } clone ] if ;
100 : MDB_ADDON_SLOTS ( -- slots )
101 { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
103 : link-class ( collection class -- )
105 [ 2dup member? [ 2drop ] [ push ] if ]
106 [ 1vector >>classes ] if* drop ; inline
108 : link-collection ( class collection -- )
110 [ MDB_COLLECTION set-word-prop ] 2bi ; inline
112 : mdb-check-slots ( superclass slots -- superclass slots )
113 over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
114 [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
116 : set-slot-map ( class option-list -- )
117 optl>map [ MDB_SLOTDEF_MAP set-word-prop ] 2keep
119 [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
121 : set-index-map ( class index-list -- )
122 [ dup user-defined-key-index ] dip index-list>map 2array
123 assoc-union-all MDB_INDEX_MAP set-word-prop ; inline
125 M: tuple-class tuple-collection ( tuple -- mdb-collection )
128 M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
129 class-of (mdb-collection) ;
131 M: mdb-persistent mdb-slot-map ( tuple -- string )
132 class-of (mdb-slot-map) ;
134 M: tuple-class mdb-slot-map ( class -- assoc )
137 M: mdb-collection mdb-slot-map ( collection -- assoc )
138 classes>> [ mdb-slot-map ] map assoc-union-all ;
140 M: mdb-persistent mdb-index-map
141 class-of (mdb-index-map) ;
142 M: tuple-class mdb-index-map
144 M: mdb-collection mdb-index-map
145 classes>> [ mdb-index-map ] map assoc-union-all ;
149 : collection-map ( -- assoc )
150 mdb-persistent MDB_COLLECTION_MAP word-prop
151 [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
152 [ set-word-prop ] keep ] unless* ; inline
154 : slot-option? ( tuple slot option -- ? )
155 [ swap mdb-slot-map at ] dip
156 '[ _ swap member-eq? ] [ f ] if* ;
160 GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
161 M: string <mdb-tuple-collection>
162 collection-map [ ] [ key? ] 2bi
163 [ at ] [ [ mdb-tuple-collection new dup ] 2dip
164 [ [ >>name ] keep ] dip set-at ] if ; inline
165 M: mdb-tuple-collection <mdb-tuple-collection> ;
166 M: mdb-collection <mdb-tuple-collection>
167 [ name>> <mdb-tuple-collection> ] keep
169 [ capped>> >>capped ]
174 : user-defined-key? ( tuple slot -- ? )
175 +user-defined-key+ slot-option? ;
177 : transient-slot? ( tuple slot -- ? )
178 +transient+ slot-option? ;
180 : load-slot? ( tuple slot -- ? )
181 +load+ slot-option? ;