132 lines
3.5 KiB
Factor
132 lines
3.5 KiB
Factor
USING: accessors assocs classes classes.mixin classes.tuple vectors math
|
|
classes.tuple.parser formatting generalizations kernel sequences fry
|
|
prettyprint strings compiler.units slots tools.walker words arrays mongodb.persistent ;
|
|
|
|
IN: mongodb.tuple
|
|
|
|
MIXIN: mdb-persistent
|
|
|
|
|
|
GENERIC: mdb-slot-definitions>> ( tuple -- string )
|
|
GENERIC: mdb-collection>> ( object -- mdb-collection )
|
|
|
|
CONSTANT: MDB_COLLECTIONS "mdb_collections"
|
|
CONSTANT: MDB_COL_PROP "mdb_collection"
|
|
CONSTANT: MDB_SLOTOPT_PROP "mdb_slot_options"
|
|
|
|
SLOT: _id
|
|
CONSTANT: MDB_P_SLOTS { "_id" }
|
|
CONSTANT: MDB_OID "_id"
|
|
|
|
SYMBOLS: +transient+ +load+ ;
|
|
|
|
UNION: boolean t POSTPONE: f ;
|
|
|
|
TUPLE: mdb-collection
|
|
{ name string }
|
|
{ capped boolean initial: f }
|
|
{ size integer initial: -1 }
|
|
{ max integer initial: -1 }
|
|
{ classes sequence } ;
|
|
|
|
<PRIVATE
|
|
|
|
: (mdb-collection>>) ( class -- mdb-collection )
|
|
dup props>> [ MDB_COL_PROP ] dip at
|
|
[ [ drop ] dip ]
|
|
[ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive
|
|
|
|
: (mdb-slot-definitions>>) ( class -- slot-defs )
|
|
superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline
|
|
|
|
: link-class ( class collection -- )
|
|
tuck classes>> ! col class v{}
|
|
[ 2dup member? [ 2drop ] [ push ] if ]
|
|
[ 1vector >>classes ] if* drop ;
|
|
|
|
PRIVATE>
|
|
|
|
M: tuple-class mdb-collection>> ( tuple -- mdb-collection )
|
|
(mdb-collection>>) ;
|
|
|
|
M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection )
|
|
class (mdb-collection>>) ;
|
|
|
|
M: mdb-persistent mdb-slot-definitions>> ( tuple -- string )
|
|
class (mdb-slot-definitions>>) ;
|
|
|
|
M: tuple-class mdb-slot-definitions>> ( class -- assoc )
|
|
(mdb-slot-definitions>>) ;
|
|
|
|
M: mdb-collection mdb-slot-definitions>> ( collection -- assoc )
|
|
classes>> [ mdb-slot-definitions>> ] map assoc-combine ;
|
|
|
|
: link-collection ( class collection -- )
|
|
2dup link-class
|
|
swap [ MDB_COL_PROP ] dip props>> set-at ; inline
|
|
|
|
: declared-collections> ( -- assoc )
|
|
MDB_COLLECTIONS mdb-persistent props>> at
|
|
[ H{ } clone
|
|
[ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep
|
|
] unless* ;
|
|
|
|
: <mdb-collection> ( name -- mdb-collection )
|
|
declared-collections> 2dup key?
|
|
[ at ]
|
|
[ [ mdb-collection new ] 2dip
|
|
[ [ >>name dup ] keep ] dip set-at ] if ;
|
|
|
|
<PRIVATE
|
|
|
|
|
|
: mdb-check-id-slot ( superclass slots -- superclass slots )
|
|
over
|
|
all-slots [ name>> ] map [ MDB_OID ] dip memq?
|
|
[ ]
|
|
[ MDB_P_SLOTS prepend ] if ; inline
|
|
|
|
PRIVATE>
|
|
|
|
: show-persistence-info ( class -- )
|
|
H{ } clone
|
|
[ [ dup mdb-collection>> "collection" ] dip set-at ] keep
|
|
[ [ mdb-slot-definitions>> "slots" ] dip set-at ] keep . ;
|
|
|
|
GENERIC: mdb-persisted? ( tuple -- ? )
|
|
|
|
M: mdb-persistent mdb-persisted? ( tuple -- ? )
|
|
_id>> f = not ;
|
|
|
|
M: assoc mdb-persisted? ( assoc -- ? )
|
|
[ MDB_OID ] dip key? ; inline
|
|
|
|
: MDBTUPLE:
|
|
parse-tuple-definition
|
|
mdb-check-id-slot
|
|
define-tuple-class ; parsing
|
|
|
|
<PRIVATE
|
|
|
|
: split-olist ( seq -- key options )
|
|
[ first ] [ rest ] bi ; inline
|
|
|
|
|
|
: optl>assoc ( seq -- assoc )
|
|
[ dup assoc?
|
|
[ 1array { "" } append ] unless
|
|
] map ;
|
|
|
|
PRIVATE>
|
|
|
|
: set-slot-options ( class options -- )
|
|
H{ } clone tuck '[ _ [ split-olist optl>assoc swap ] dip set-at ] each
|
|
over [ MDB_SLOTOPT_PROP ] dip props>> set-at
|
|
dup mdb-collection>> link-collection ;
|
|
|
|
: define-collection ( class collection options -- )
|
|
[ [ dup ] dip link-collection ] dip ! cl options
|
|
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
|
|
set-slot-options ;
|
|
|