another checkpoint - tuple integration seems to work
parent
c80084d606
commit
a61796fe76
|
@ -2,10 +2,8 @@ USING: accessors constructors kernel strings uuid ;
|
||||||
|
|
||||||
IN: bson.constants
|
IN: bson.constants
|
||||||
|
|
||||||
TUPLE: objid id ;
|
|
||||||
|
|
||||||
: <objid> ( -- objid )
|
: <objid> ( -- objid )
|
||||||
objid new uuid1 >>id ; inline
|
uuid1 ; inline
|
||||||
|
|
||||||
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
||||||
|
|
||||||
|
|
|
@ -186,11 +186,6 @@ M: bson-binary-custom element-binary-read ( size type -- dbref )
|
||||||
read-cstring
|
read-cstring
|
||||||
read-cstring objref boa ;
|
read-cstring objref boa ;
|
||||||
|
|
||||||
M: bson-binary-uuid element-binary-read ( size type -- object )
|
|
||||||
2drop
|
|
||||||
read-cstring
|
|
||||||
objid boa ;
|
|
||||||
|
|
||||||
M: bson-binary-bytes element-binary-read ( size type -- bytes )
|
M: bson-binary-bytes element-binary-read ( size type -- bytes )
|
||||||
drop read ;
|
drop read ;
|
||||||
|
|
||||||
|
|
|
@ -77,7 +77,6 @@ M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
|
||||||
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
|
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
|
||||||
|
|
||||||
M: oid bson-type? ( word -- type ) drop T_OID ;
|
M: oid bson-type? ( word -- type ) drop T_OID ;
|
||||||
M: objid bson-type? ( objid -- type ) drop T_Binary ;
|
|
||||||
M: objref bson-type? ( objref -- type ) drop T_Binary ;
|
M: objref bson-type? ( objref -- type ) drop T_Binary ;
|
||||||
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
|
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
|
||||||
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
|
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
|
||||||
|
@ -126,16 +125,11 @@ M: quotation bson-write ( quotation -- )
|
||||||
M: oid bson-write ( oid -- )
|
M: oid bson-write ( oid -- )
|
||||||
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
|
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
|
||||||
|
|
||||||
M: objid bson-write ( oid -- )
|
|
||||||
id>> [ binary ] dip '[ _ write-cstring ] with-byte-writer
|
|
||||||
[ length write-int32 ] keep
|
|
||||||
T_Binary_UUID write-byte write ;
|
|
||||||
|
|
||||||
M: objref bson-write ( objref -- )
|
M: objref bson-write ( objref -- )
|
||||||
[ binary ] dip
|
[ binary ] dip
|
||||||
'[ _
|
'[ _
|
||||||
[ ns>> write-cstring ]
|
[ ns>> write-cstring ]
|
||||||
[ objid>> id>> write-cstring ] bi ] with-byte-writer
|
[ objid>> write-cstring ] bi ] with-byte-writer
|
||||||
[ length write-int32 ] keep
|
[ length write-int32 ] keep
|
||||||
T_Binary_Custom write-byte write ;
|
T_Binary_Custom write-byte write ;
|
||||||
|
|
||||||
|
|
|
@ -195,6 +195,7 @@ MEMO: reserved-namespace? ( name -- ? )
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
MEMO: ensure-collection ( collection -- fq-collection )
|
MEMO: ensure-collection ( collection -- fq-collection )
|
||||||
|
dup mdb-collection? [ name>> ] when
|
||||||
"." split1 over mdb name>> =
|
"." split1 over mdb name>> =
|
||||||
[ nip ] [ drop ] if
|
[ nip ] [ drop ] if
|
||||||
[ ] [ reserved-namespace? ] bi
|
[ ] [ reserved-namespace? ] bi
|
||||||
|
|
|
@ -1,10 +1,16 @@
|
||||||
|
|
||||||
USING: accessors arrays assocs bson.constants classes classes.tuple
|
USING: accessors arrays assocs bson.constants classes classes.tuple
|
||||||
continuations fry kernel mongodb.driver sequences
|
combinators continuations fry kernel mongodb.driver sequences strings
|
||||||
vectors words ;
|
vectors words ;
|
||||||
|
|
||||||
|
IN: mongodb.tuple
|
||||||
|
|
||||||
|
SINGLETONS: +transient+ +load+ ;
|
||||||
|
|
||||||
IN: mongodb.tuple.collection
|
IN: mongodb.tuple.collection
|
||||||
|
|
||||||
|
FROM: mongodb.tuple => +transient+ +load+ ;
|
||||||
|
|
||||||
MIXIN: mdb-persistent
|
MIXIN: mdb-persistent
|
||||||
|
|
||||||
SLOT: _id
|
SLOT: _id
|
||||||
|
@ -14,7 +20,7 @@ TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
|
||||||
|
|
||||||
GENERIC: tuple-collection ( object -- mdb-collection )
|
GENERIC: tuple-collection ( object -- mdb-collection )
|
||||||
|
|
||||||
GENERIC: mdb-slot-list ( tuple -- string )
|
GENERIC: mdb-slot-map ( tuple -- string )
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -27,7 +33,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
|
||||||
[ nip ]
|
[ nip ]
|
||||||
[ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
|
[ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
|
||||||
|
|
||||||
: (mdb-slot-list) ( class -- slot-defs )
|
: (mdb-slot-map) ( class -- slot-defs )
|
||||||
superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
|
superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
|
||||||
|
|
||||||
: split-optl ( seq -- key options )
|
: split-optl ( seq -- key options )
|
||||||
|
@ -59,8 +65,8 @@ PRIVATE>
|
||||||
over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
|
over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
|
||||||
[ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
|
[ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
|
||||||
|
|
||||||
: set-slot-options ( class options -- )
|
: set-slot-map ( class options -- )
|
||||||
'[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep
|
'[ _ optl>map MDB_SLOTDEF_LIST set-word-prop ] keep
|
||||||
dup tuple-collection link-collection ; inline
|
dup tuple-collection link-collection ; inline
|
||||||
|
|
||||||
M: tuple-class tuple-collection ( tuple -- mdb-collection )
|
M: tuple-class tuple-collection ( tuple -- mdb-collection )
|
||||||
|
@ -69,22 +75,44 @@ M: tuple-class tuple-collection ( tuple -- mdb-collection )
|
||||||
M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
|
M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
|
||||||
class (mdb-collection) ;
|
class (mdb-collection) ;
|
||||||
|
|
||||||
M: mdb-persistent mdb-slot-list ( tuple -- string )
|
M: mdb-persistent mdb-slot-map ( tuple -- string )
|
||||||
class (mdb-slot-list) ;
|
class (mdb-slot-map) ;
|
||||||
|
|
||||||
M: tuple-class mdb-slot-list ( class -- assoc )
|
M: tuple-class mdb-slot-map ( class -- assoc )
|
||||||
(mdb-slot-list) ;
|
(mdb-slot-map) ;
|
||||||
|
|
||||||
M: mdb-collection mdb-slot-list ( collection -- assoc )
|
M: mdb-collection mdb-slot-map ( collection -- assoc )
|
||||||
classes>> [ mdb-slot-list ] map assoc-combine ;
|
classes>> [ mdb-slot-map ] map assoc-combine ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: collection-map ( -- assoc )
|
: collection-map ( -- assoc )
|
||||||
MDB_COLLECTION_MAP mdb-persistent word-prop
|
mdb-persistent MDB_COLLECTION_MAP word-prop
|
||||||
[ mdb-persistent MDB_COLLECTION_MAP H{ } clone
|
[ mdb-persistent MDB_COLLECTION_MAP H{ } clone
|
||||||
[ set-word-prop ] keep ] unless* ; inline
|
[ set-word-prop ] keep ] unless* ; inline
|
||||||
|
|
||||||
|
: slot-option? ( tuple slot option -- ? )
|
||||||
|
[ swap mdb-slot-map at ] dip
|
||||||
|
'[ _ swap key? ] [ f ] if* ;
|
||||||
|
|
||||||
: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
|
PRIVATE>
|
||||||
|
|
||||||
|
GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
|
||||||
|
M: string <mdb-tuple-collection> ( name -- mdb-tuple-collection )
|
||||||
collection-map [ ] [ key? ] 2bi
|
collection-map [ ] [ key? ] 2bi
|
||||||
[ at ] [ [ mdb-tuple-collection new dup ] 2dip
|
[ at ] [ [ mdb-tuple-collection new dup ] 2dip
|
||||||
[ [ >>name ] keep ] dip set-at ] if ; inline
|
[ [ >>name ] keep ] dip set-at ] if ; inline
|
||||||
|
M: mdb-tuple-collection <mdb-tuple-collection> ( mdb-tuple-collection -- mdb-tuple-collection ) ;
|
||||||
|
M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collection )
|
||||||
|
[ name>> <mdb-tuple-collection> ] keep
|
||||||
|
{
|
||||||
|
[ capped>> >>capped ]
|
||||||
|
[ size>> >>size ]
|
||||||
|
[ max>> >>max ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
: transient-slot? ( tuple slot -- ? )
|
||||||
|
+transient+ slot-option? ;
|
||||||
|
|
||||||
|
: load-slot? ( tuple slot -- ? )
|
||||||
|
+load+ slot-option? ;
|
||||||
|
|
|
@ -1,11 +1,15 @@
|
||||||
USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
|
USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
|
||||||
mongodb.tuple.collection combinators mongodb.tuple.collection ;
|
mongodb.tuple.collection combinators mongodb.tuple.collection ;
|
||||||
|
|
||||||
|
IN: mongodb.tuple
|
||||||
|
|
||||||
|
SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
|
||||||
|
|
||||||
IN: mongodb.tuple.index
|
IN: mongodb.tuple.index
|
||||||
|
|
||||||
TUPLE: tuple-index name spec ;
|
FROM: mongodb.tuple => +fieldindex+ +compoundindex+ +deepindex+ ;
|
||||||
|
|
||||||
SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
|
TUPLE: tuple-index name spec ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -47,7 +51,7 @@ SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: tuple-index-list ( mdb-collection/class -- seq )
|
: tuple-index-list ( mdb-collection/class -- seq )
|
||||||
mdb-slot-list V{ } clone tuck
|
mdb-slot-map V{ } clone tuck
|
||||||
'[ [ is-index-declaration? ] filter
|
'[ [ is-index-declaration? ] filter
|
||||||
build-index-seq _ push
|
build-index-seq _ push
|
||||||
] assoc-each flatten ;
|
] assoc-each flatten ;
|
||||||
|
|
|
@ -11,7 +11,6 @@ GENERIC: tuple>assoc ( tuple -- assoc )
|
||||||
GENERIC: tuple>selector ( tuple -- selector )
|
GENERIC: tuple>selector ( tuple -- selector )
|
||||||
|
|
||||||
DEFER: assoc>tuple
|
DEFER: assoc>tuple
|
||||||
DEFER: mdb-persistent?
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -41,19 +40,23 @@ DEFER: mdb-persistent?
|
||||||
: add-storable ( assoc ns -- )
|
: add-storable ( assoc ns -- )
|
||||||
[ H{ } clone ] dip mdb-store-list get at+
|
[ H{ } clone ] dip mdb-store-list get at+
|
||||||
[ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
|
[ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
|
||||||
|
|
||||||
: write-tuple-fields ( mirror assoc conv-quot -- )
|
: write-field? ( tuple key value -- ? )
|
||||||
swap [ dup ] dip ! m a a q
|
[ [ 2drop ] dip not ] [ drop transient-slot? ] 3bi or not ; inline
|
||||||
'[ [ dup mdb-persistent?
|
|
||||||
|
: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
|
||||||
|
swap dupd ! m t q q a
|
||||||
|
'[ _ 2over write-field?
|
||||||
|
[ dup mdb-persistent?
|
||||||
[ _ keep
|
[ _ keep
|
||||||
[ tuple-collection ] keep
|
[ tuple-collection ] keep
|
||||||
[ add-storable ] dip
|
[ add-storable ] dip
|
||||||
[ tuple-collection ] [ _id>> ] bi <objref> ]
|
[ tuple-collection ] [ _id>> ] bi <objref> ]
|
||||||
[ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if*
|
[ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if
|
||||||
] assoc-each ;
|
] assoc-each ;
|
||||||
|
|
||||||
: prepare-assoc ( tuple -- assoc mirror assoc )
|
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
|
||||||
<mirror> H{ } clone tuck ; inline
|
H{ } clone swap [ <mirror> ] keep pick ; inline
|
||||||
|
|
||||||
: ensure-mdb-info ( tuple -- tuple )
|
: ensure-mdb-info ( tuple -- tuple )
|
||||||
dup _id>> [ <objid> >>_id ] unless
|
dup _id>> [ <objid> >>_id ] unless
|
||||||
|
|
|
@ -28,17 +28,17 @@ PRIVATE>
|
||||||
dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
|
dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
|
||||||
|
|
||||||
: dirty? ( tuple -- ? )
|
: dirty? ( tuple -- ? )
|
||||||
MDB_DIRTY_FLAG tuple-meta at ;
|
MDB_DIRTY_FLAG tuple-meta at ;
|
||||||
|
|
||||||
: set-dirty ( tuple -- )
|
: set-dirty ( tuple -- )
|
||||||
t MDB_DIRTY_FLAG tuple-meta set-at ;
|
[ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
|
||||||
|
|
||||||
: persistent? ( tuple -- ? )
|
: persistent? ( tuple -- ? )
|
||||||
MDB_PERSISTENT_FLAG tuple-meta at ;
|
MDB_PERSISTENT_FLAG tuple-meta at ;
|
||||||
|
|
||||||
: set-persistent ( tuple -- )
|
: set-persistent ( tuple -- )
|
||||||
t MDB_PERSISTENT_FLAG tuple-meta set-at ;
|
[ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ;
|
||||||
|
|
||||||
: needs-store? ( tuple -- ? )
|
: needs-store? ( tuple -- ? )
|
||||||
[ persistent? not ] [ dirty? ] bi or ;
|
[ persistent? not ] [ dirty? ] bi or ;
|
||||||
|
|
||||||
|
|
|
@ -1,28 +1,26 @@
|
||||||
USING: accessors assocs classes classes.mixin classes.tuple vectors math
|
USING: accessors assocs classes.mixin classes.tuple
|
||||||
classes.tuple.parser formatting generalizations kernel sequences fry combinators
|
classes.tuple.parser compiler.units fry kernel mongodb.driver
|
||||||
linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants
|
mongodb.msg mongodb.tuple.collection mongodb.tuple.index
|
||||||
prettyprint strings compiler.units slots tools.walker words arrays ;
|
mongodb.tuple.persistent mongodb.tuple.state sequences strings ;
|
||||||
|
|
||||||
IN: mongodb.tuple
|
IN: mongodb.tuple
|
||||||
|
|
||||||
USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection
|
|
||||||
mongodb.tuple.index mongodb.msg ;
|
|
||||||
|
|
||||||
SYNTAX: MDBTUPLE:
|
SYNTAX: MDBTUPLE:
|
||||||
parse-tuple-definition
|
parse-tuple-definition
|
||||||
mdb-check-slots
|
mdb-check-slots
|
||||||
define-tuple-class ;
|
define-tuple-class ;
|
||||||
|
|
||||||
: define-persistent ( class collection options -- )
|
: define-persistent ( class collection options -- )
|
||||||
|
[ <mdb-tuple-collection> ] dip
|
||||||
[ [ dup ] dip link-collection ] dip ! cl options
|
[ [ dup ] dip link-collection ] dip ! cl options
|
||||||
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
|
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
|
||||||
set-slot-options ;
|
set-slot-map ;
|
||||||
|
|
||||||
: ensure-table ( class -- )
|
: ensure-table ( class -- )
|
||||||
tuple-collection
|
tuple-collection
|
||||||
[ create-collection ]
|
[ create-collection ]
|
||||||
[ [ tuple-index-list ] keep
|
[ [ tuple-index-list ] keep
|
||||||
'[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each
|
'[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each
|
||||||
] bi ;
|
] bi ;
|
||||||
|
|
||||||
: ensure-tables ( classes -- )
|
: ensure-tables ( classes -- )
|
||||||
|
@ -31,7 +29,7 @@ SYNTAX: MDBTUPLE:
|
||||||
: drop-table ( class -- )
|
: drop-table ( class -- )
|
||||||
tuple-collection
|
tuple-collection
|
||||||
[ [ tuple-index-list ] keep
|
[ [ tuple-index-list ] keep
|
||||||
'[ _ swap name>> drop-index ] each ]
|
'[ _ name>> swap name>> drop-index ] each ]
|
||||||
[ name>> drop-collection ] bi ;
|
[ name>> drop-collection ] bi ;
|
||||||
|
|
||||||
: recreate-table ( class -- )
|
: recreate-table ( class -- )
|
||||||
|
@ -41,19 +39,19 @@ SYNTAX: MDBTUPLE:
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
GENERIC: id-selector ( object -- selector )
|
GENERIC: id-selector ( object -- selector )
|
||||||
M: objid id-selector ( objid -- selector )
|
M: string id-selector ( objid -- selector )
|
||||||
"_id" H{ } clone [ set-at ] keep ; inline
|
"_id" H{ } clone [ set-at ] keep ; inline
|
||||||
M: mdb-persistent id-selector ( mdb-persistent -- selector )
|
M: mdb-persistent id-selector ( mdb-persistent -- selector )
|
||||||
id>> id-selector ;
|
_id>> id-selector ;
|
||||||
|
|
||||||
: (save-tuples) ( collection assoc -- )
|
: (save-tuples) ( collection assoc -- )
|
||||||
swap '[ [ _ ] 2dip
|
swap '[ [ _ ] 2dip
|
||||||
[ id-selector ] dip
|
[ id-selector ] dip
|
||||||
<update> update ] assoc-each ; inline
|
<update> >upsert update ] assoc-each ; inline
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: save-tuple ( tuple -- )
|
: save-tuple ( tuple -- )
|
||||||
tuple>assoc [ (save-tuples) ] assoc-each ;
|
tuple>storable [ (save-tuples) ] assoc-each ;
|
||||||
|
|
||||||
: update-tuple ( tuple -- )
|
: update-tuple ( tuple -- )
|
||||||
save-tuple ;
|
save-tuple ;
|
||||||
|
|
Loading…
Reference in New Issue