started working on transparent persistence for tuples (using dynamic subclassing)
*** state: broken ***db4
parent
dc825d21c5
commit
f67441f493
|
|
@ -0,0 +1,15 @@
|
||||||
|
USING: mongodb.persistent ;
|
||||||
|
|
||||||
|
IN: mongodb
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
GENERIC: store ( tuple/ht -- tuple/ht )
|
||||||
|
GENERIC: load ( example -- tuple/ht )
|
||||||
|
|
||||||
|
M: tuple store ( tuple -- tuple )
|
||||||
|
[ check-persistent-tuple ] keep ;
|
||||||
|
|
||||||
|
M: persistent-tuple store ( ptuple -- ptuple )
|
||||||
|
;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,42 @@
|
||||||
|
USING: formatting words classes.mixin kernel fry compiler.units
|
||||||
|
accessors classes classes.tuple ;
|
||||||
|
|
||||||
|
IN: mongodb.persistent
|
||||||
|
|
||||||
|
MIXIN: persistent-tuple
|
||||||
|
|
||||||
|
SLOT: _p_oid
|
||||||
|
SLOT: _p_info
|
||||||
|
|
||||||
|
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
||||||
|
|
||||||
|
TUPLE: persistent-info type vocab collection dirty? mt ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: P_VOCAB ( -- string )
|
||||||
|
"mongodb.persistent" ; inline
|
||||||
|
|
||||||
|
: P_SLOTS ( -- array )
|
||||||
|
{ "_p_oid" "_p_info" } ;
|
||||||
|
|
||||||
|
: define-persistent-tuple ( class name -- class )
|
||||||
|
P_VOCAB create ! class word
|
||||||
|
dup dup '[ _ _ [ ] curry define ] with-compilation-unit
|
||||||
|
dup [ swap ] dip
|
||||||
|
'[ _ _ P_SLOTS define-tuple-class
|
||||||
|
_ persistent-tuple define-mixin-class ] with-compilation-unit ;
|
||||||
|
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
GENERIC: persistent-tuple-class ( tuple -- class )
|
||||||
|
|
||||||
|
M: tuple persistent-tuple-class ( tuple -- class )
|
||||||
|
class persistent-tuple-class ;
|
||||||
|
|
||||||
|
M: tuple-class persistent-tuple-class ( class -- class' )
|
||||||
|
[ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class
|
||||||
|
[ "%s_%s" sprintf ] dip swap dup ! class new_name new_name
|
||||||
|
P_VOCAB lookup dup ! class new_name vo/f vo/f
|
||||||
|
[ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ;
|
||||||
Loading…
Reference in New Issue