checkpoint tuple integration
Sascha Matzke
parent
f3a7f9d6be
commit
33d99b6076
|
|
@ -1,4 +1,4 @@
|
|||
USING: accessors kernel math parser sequences strings uuid ;
|
||||
USING: accessors constructors kernel strings uuid ;
|
||||
|
||||
IN: bson.constants
|
||||
|
||||
|
|
@ -11,6 +11,8 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
|||
|
||||
TUPLE: objref ns objid ;
|
||||
|
||||
CONSTRUCTOR: objref ( ns objid -- objref ) ;
|
||||
|
||||
TUPLE: mdbregexp { regexp string } { options string } ;
|
||||
|
||||
: <mdbregexp> ( string -- mdbregexp )
|
||||
|
|
@ -18,7 +20,7 @@ TUPLE: mdbregexp { regexp string } { options string } ;
|
|||
|
||||
|
||||
CONSTANT: MDB_OID_FIELD "_id"
|
||||
CONSTANT: MDB_INTERNAL_FIELD "_mdb_"
|
||||
CONSTANT: MDB_META_FIELD "_mfd"
|
||||
|
||||
CONSTANT: T_EOO 0
|
||||
CONSTANT: T_Double 1
|
||||
|
|
|
|||
|
|
@ -149,7 +149,7 @@ M: sequence bson-write ( array -- )
|
|||
[ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline
|
||||
|
||||
: skip-field? ( name -- boolean )
|
||||
{ "_id" "_mdb" } member? ; inline
|
||||
{ "_id" "_mfd" } member? ; inline
|
||||
|
||||
M: assoc bson-write ( assoc -- )
|
||||
'[ _ [ write-oid ] keep
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@ TUPLE: mdb-collection
|
|||
{ size integer initial: -1 }
|
||||
{ max integer initial: -1 } ;
|
||||
|
||||
CONSTRUCTOR: mdb-collection ( name -- collection ) ;
|
||||
: <mdb-collection> ( name -- collection )
|
||||
[ mdb-collection new ] dip >>name ; inline
|
||||
|
||||
CONSTANT: MDB-GENERAL-ERROR 1
|
||||
|
||||
|
|
@ -73,6 +74,10 @@ SYNTAX: r/ ( token -- mdbregexp )
|
|||
[ >>mdb-stream ] prepose
|
||||
with-disposal ] with-scope ; inline
|
||||
|
||||
: build-id-selector ( assoc -- selector )
|
||||
[ MDB_OID_FIELD swap at ] keep
|
||||
H{ } clone [ set-at ] keep ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: index-collection ( -- ns )
|
||||
|
|
@ -161,7 +166,8 @@ M: mdb-collection create-collection ( mdb-collection -- )
|
|||
[ [ size>> "size" ] dip set-at ]
|
||||
[ [ max>> "max" ] dip set-at ] 2tri ] when
|
||||
] 2bi
|
||||
] keep <mdb-query-msg> 1 >>return# send-query-plain objects>> first check-ok
|
||||
] keep <mdb-query-msg> 1 >>return# send-query-plain
|
||||
objects>> first check-ok
|
||||
[ "could not create collection" throw ] unless ;
|
||||
|
||||
: load-collection-list ( -- collection-list )
|
||||
|
|
@ -238,7 +244,7 @@ GENERIC: find-one ( mdb-query -- result/f )
|
|||
M: mdb-query-msg find-one
|
||||
1 >>return# send-query-plain objects>> [ first ] [ f ] if* ;
|
||||
|
||||
GENERIC: count ( collection query -- result )
|
||||
GENERIC: count ( collection selector -- result )
|
||||
M: assoc count
|
||||
[ "count" H{ } clone [ set-at ] keep ] dip
|
||||
[ over [ "query" ] dip set-at ] when*
|
||||
|
|
|
|||
|
|
@ -0,0 +1,90 @@
|
|||
|
||||
USING: accessors arrays assocs bson.constants classes classes.tuple
|
||||
continuations fry kernel mongodb.driver sequences
|
||||
vectors words ;
|
||||
|
||||
IN: mongodb.tuple.collection
|
||||
|
||||
MIXIN: mdb-persistent
|
||||
|
||||
SLOT: _id
|
||||
SLOT: _mfd
|
||||
|
||||
TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
|
||||
|
||||
GENERIC: tuple-collection ( object -- mdb-collection )
|
||||
|
||||
GENERIC: mdb-slot-list ( tuple -- string )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: MDB_COLLECTION "_mdb_col"
|
||||
CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list"
|
||||
CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
|
||||
|
||||
: (mdb-collection) ( class -- mdb-collection )
|
||||
dup MDB_COLLECTION word-prop
|
||||
[ nip ]
|
||||
[ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
|
||||
|
||||
: (mdb-slot-list) ( class -- slot-defs )
|
||||
superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
|
||||
|
||||
: split-optl ( seq -- key options )
|
||||
[ first ] [ rest ] bi ; inline
|
||||
|
||||
: opt>assoc ( seq -- assoc )
|
||||
[ dup assoc?
|
||||
[ 1array { "" } append ] unless ] map ;
|
||||
|
||||
: optl>map ( seq -- map )
|
||||
H{ } clone tuck
|
||||
'[ split-optl opt>assoc swap _ set-at ] each ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: MDB_ADDON_SLOTS ( -- slots )
|
||||
{ } [ MDB_OID_FIELD MDB_META_FIELD ] with-datastack ; inline
|
||||
|
||||
: link-class ( collection class -- )
|
||||
over classes>>
|
||||
[ 2dup member? [ 2drop ] [ push ] if ]
|
||||
[ 1vector >>classes ] if* drop ; inline
|
||||
|
||||
: link-collection ( class collection -- )
|
||||
[ swap link-class ]
|
||||
[ MDB_COLLECTION set-word-prop ] 2bi ; inline
|
||||
|
||||
: mdb-check-slots ( superclass slots -- superclass slots )
|
||||
over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
|
||||
[ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
|
||||
|
||||
: set-slot-options ( class options -- )
|
||||
'[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep
|
||||
dup tuple-collection link-collection ; inline
|
||||
|
||||
M: tuple-class tuple-collection ( tuple -- mdb-collection )
|
||||
(mdb-collection) ;
|
||||
|
||||
M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
|
||||
class (mdb-collection) ;
|
||||
|
||||
M: mdb-persistent mdb-slot-list ( tuple -- string )
|
||||
class (mdb-slot-list) ;
|
||||
|
||||
M: tuple-class mdb-slot-list ( class -- assoc )
|
||||
(mdb-slot-list) ;
|
||||
|
||||
M: mdb-collection mdb-slot-list ( collection -- assoc )
|
||||
classes>> [ mdb-slot-list ] map assoc-combine ;
|
||||
|
||||
: collection-map ( -- assoc )
|
||||
MDB_COLLECTION_MAP mdb-persistent word-prop
|
||||
[ mdb-persistent MDB_COLLECTION_MAP H{ } clone
|
||||
[ set-word-prop ] keep ] unless* ; inline
|
||||
|
||||
: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
|
||||
collection-map [ ] [ key? ] 2bi
|
||||
[ at ] [ [ mdb-tuple-collection new dup ] 2dip
|
||||
[ [ >>name ] keep ] dip set-at ] if ; inline
|
||||
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
|
||||
mongodb.tuple.collection combinators mongodb.tuple.collection ;
|
||||
|
||||
IN: mongodb.tuple.index
|
||||
|
||||
TUPLE: tuple-index name spec ;
|
||||
|
||||
SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: index-type ( type -- name )
|
||||
{ { +fieldindex+ [ "field" ] }
|
||||
{ +deepindex+ [ "deep" ] }
|
||||
{ +compoundindex+ [ "compound" ] } } case ;
|
||||
|
||||
: index-name ( slot index-spec -- name )
|
||||
[ first index-type ] keep
|
||||
rest "-" join
|
||||
"%s-%s-%s-Idx" sprintf ;
|
||||
|
||||
: build-index ( element slot -- assoc )
|
||||
swap [ <linked-hash> ] 2dip
|
||||
[ rest ] keep first ! assoc slot options itype
|
||||
{ { +fieldindex+ [ drop [ 1 ] dip pick set-at ] }
|
||||
{ +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] }
|
||||
{ +compoundindex+ [
|
||||
2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options
|
||||
over '[ _ [ 1 ] 2dip set-at ] each ] }
|
||||
} case ;
|
||||
|
||||
: build-index-seq ( slot optlist -- index-seq )
|
||||
[ V{ } clone ] 2dip pick ! v{} slot optl v{}
|
||||
[ swap ] dip ! v{} optl slot v{ }
|
||||
'[ _ tuple-index new ! element slot exemplar
|
||||
2over swap index-name >>name ! element slot clone
|
||||
[ build-index ] dip swap >>spec _ push
|
||||
] each ;
|
||||
|
||||
: is-index-declaration? ( entry -- ? )
|
||||
first
|
||||
{ { +fieldindex+ [ t ] }
|
||||
{ +compoundindex+ [ t ] }
|
||||
{ +deepindex+ [ t ] }
|
||||
[ drop f ] } case ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: tuple-index-list ( mdb-collection/class -- seq )
|
||||
mdb-slot-list V{ } clone tuck
|
||||
'[ [ is-index-declaration? ] filter
|
||||
build-index-seq _ push
|
||||
] assoc-each flatten ;
|
||||
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
USING: accessors assocs classes fry kernel linked-assocs math mirrors
|
||||
namespaces sequences strings vectors words bson.constants
|
||||
continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ;
|
||||
|
||||
IN: mongodb.tuple.persistent
|
||||
|
||||
SYMBOL: mdb-store-list
|
||||
|
||||
GENERIC: tuple>assoc ( tuple -- assoc )
|
||||
|
||||
GENERIC: tuple>selector ( tuple -- selector )
|
||||
|
||||
DEFER: assoc>tuple
|
||||
DEFER: mdb-persistent?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: mdbinfo>tuple-class ( tuple-info -- class )
|
||||
[ first ] keep second lookup ; inline
|
||||
|
||||
: tuple-instance ( tuple-info -- instance )
|
||||
mdbinfo>tuple-class new ; inline
|
||||
|
||||
: [keys>tuple] ( mirror assoc -- quot: ( elt -- ) )
|
||||
'[ dup _ at assoc>tuple swap _ set-at ] ;
|
||||
|
||||
: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
|
||||
[ tuple-info tuple-instance dup
|
||||
<mirror> [ keys ] keep ] keep swap ; inline
|
||||
|
||||
: make-tuple ( assoc -- tuple )
|
||||
prepare-assoc>tuple [keys>tuple] each
|
||||
[ set-persistent ] keep ; inline
|
||||
|
||||
: at+ ( value key assoc -- value )
|
||||
2dup key?
|
||||
[ at nip ] [ [ dup ] 2dip set-at ] if ; inline
|
||||
|
||||
: data-tuple? ( tuple -- ? )
|
||||
dup tuple?
|
||||
[ assoc? not ] [ drop f ] if ; inline
|
||||
|
||||
: add-storable ( assoc ns -- )
|
||||
[ H{ } clone ] dip mdb-store-list get at+
|
||||
[ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
|
||||
|
||||
: write-tuple-fields ( mirror assoc conv-quot -- )
|
||||
swap [ dup ] dip ! m a a q
|
||||
'[ [ dup mdb-persistent?
|
||||
[ _ keep
|
||||
[ tuple-collection ] keep
|
||||
[ add-storable ] dip
|
||||
[ tuple-collection ] [ _id>> ] bi <objref> ]
|
||||
[ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if*
|
||||
] assoc-each ;
|
||||
|
||||
: prepare-assoc ( tuple -- assoc mirror assoc )
|
||||
<mirror> H{ } clone tuck ; inline
|
||||
|
||||
: ensure-mdb-info ( tuple -- tuple )
|
||||
dup _id>> [ <objid> >>_id ] unless
|
||||
[ set-persistent ] keep ; inline
|
||||
|
||||
: with-store-list ( quot: ( -- ) -- store-assoc )
|
||||
[ H{ } clone dup mdb-store-list ] dip with-variable ; inline
|
||||
|
||||
: (tuple>assoc) ( tuple -- assoc )
|
||||
[ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
|
||||
over set-tuple-info ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: tuple>storable ( tuple -- storable )
|
||||
M: mdb-persistent tuple>storable ( mdb-persistent -- store-list )
|
||||
'[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline
|
||||
|
||||
M: mdb-persistent tuple>assoc ( tuple -- assoc )
|
||||
ensure-mdb-info (tuple>assoc) ;
|
||||
|
||||
M: tuple tuple>assoc ( tuple -- assoc )
|
||||
(tuple>assoc) ;
|
||||
|
||||
M: tuple tuple>selector ( tuple -- assoc )
|
||||
prepare-assoc [ tuple>selector ] write-tuple-fields ;
|
||||
|
||||
: assoc>tuple ( assoc -- tuple )
|
||||
dup assoc?
|
||||
[ [ dup tuple-info?
|
||||
[ make-tuple ]
|
||||
[ ] if ] [ drop ] recover
|
||||
] [ ] if ; inline
|
||||
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
USING: classes kernel accessors sequences assocs mongodb.tuple.collection ;
|
||||
|
||||
IN: mongodb.tuple.state
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: MDB_TUPLE_INFO "_mfd_t_info"
|
||||
CONSTANT: MDB_DIRTY_FLAG "d?"
|
||||
CONSTANT: MDB_PERSISTENT_FLAG "p?"
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <tuple-info> ( tuple -- tuple-info )
|
||||
class V{ } clone tuck
|
||||
[ [ name>> ] dip push ]
|
||||
[ [ vocabulary>> ] dip push ] 2bi ; inline
|
||||
|
||||
: tuple-info ( assoc -- tuple-info )
|
||||
[ MDB_TUPLE_INFO ] dip at ; inline
|
||||
|
||||
: set-tuple-info ( tuple assoc -- )
|
||||
[ <tuple-info> MDB_TUPLE_INFO ] dip set-at ; inline
|
||||
|
||||
: tuple-info? ( assoc -- ? )
|
||||
[ MDB_TUPLE_INFO ] dip key? ;
|
||||
|
||||
: tuple-meta ( tuple -- assoc )
|
||||
dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
|
||||
|
||||
: dirty? ( tuple -- ? )
|
||||
MDB_DIRTY_FLAG tuple-meta at ;
|
||||
|
||||
: set-dirty ( tuple -- )
|
||||
t MDB_DIRTY_FLAG tuple-meta set-at ;
|
||||
|
||||
: persistent? ( tuple -- ? )
|
||||
MDB_PERSISTENT_FLAG tuple-meta at ;
|
||||
|
||||
: set-persistent ( tuple -- )
|
||||
t MDB_PERSISTENT_FLAG tuple-meta set-at ;
|
||||
|
||||
: needs-store? ( tuple -- ? )
|
||||
[ persistent? not ] [ dirty? ] bi or ;
|
||||
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
USING: accessors assocs classes classes.mixin classes.tuple vectors math
|
||||
classes.tuple.parser formatting generalizations kernel sequences fry combinators
|
||||
linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants
|
||||
prettyprint strings compiler.units slots tools.walker words arrays ;
|
||||
|
||||
IN: mongodb.tuple
|
||||
|
||||
USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection
|
||||
mongodb.tuple.index mongodb.msg ;
|
||||
|
||||
SYNTAX: MDBTUPLE:
|
||||
parse-tuple-definition
|
||||
mdb-check-slots
|
||||
define-tuple-class ;
|
||||
|
||||
: define-persistent ( class collection options -- )
|
||||
[ [ dup ] dip link-collection ] dip ! cl options
|
||||
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
|
||||
set-slot-options ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
tuple-collection
|
||||
[ create-collection ]
|
||||
[ [ tuple-index-list ] keep
|
||||
'[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each
|
||||
] bi ;
|
||||
|
||||
: ensure-tables ( classes -- )
|
||||
[ ensure-table ] each ;
|
||||
|
||||
: drop-table ( class -- )
|
||||
tuple-collection
|
||||
[ [ tuple-index-list ] keep
|
||||
'[ _ swap name>> drop-index ] each ]
|
||||
[ name>> drop-collection ] bi ;
|
||||
|
||||
: recreate-table ( class -- )
|
||||
[ drop-table ]
|
||||
[ ensure-table ] bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: id-selector ( object -- selector )
|
||||
M: objid id-selector ( objid -- selector )
|
||||
"_id" H{ } clone [ set-at ] keep ; inline
|
||||
M: mdb-persistent id-selector ( mdb-persistent -- selector )
|
||||
id>> id-selector ;
|
||||
|
||||
: (save-tuples) ( collection assoc -- )
|
||||
swap '[ [ _ ] 2dip
|
||||
[ id-selector ] dip
|
||||
<update> update ] assoc-each ; inline
|
||||
PRIVATE>
|
||||
|
||||
: save-tuple ( tuple -- )
|
||||
tuple>assoc [ (save-tuples) ] assoc-each ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
save-tuple ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
save-tuple ;
|
||||
|
||||
: delete-tuple ( tuple -- )
|
||||
dup persistent?
|
||||
[ [ tuple-collection name>> ] keep
|
||||
id-selector delete ] [ drop ] if ;
|
||||
|
||||
: tuple>query ( tuple -- query )
|
||||
[ tuple-collection name>> ] keep
|
||||
tuple>selector <query> ;
|
||||
|
||||
: select-tuple ( tuple/query -- tuple/f )
|
||||
dup mdb-query-msg? [ ] [ tuple>query ] if
|
||||
find-one [ assoc>tuple ] [ f ] if* ;
|
||||
|
||||
: select-tuples ( tuple/query -- cursor tuples/f )
|
||||
dup mdb-query-msg? [ ] [ tuple>query ] if
|
||||
find [ assoc>tuple ] map ;
|
||||
|
||||
: count-tuples ( tuple/query -- n )
|
||||
dup mdb-query-msg? [ tuple>query ] unless
|
||||
[ collection>> ] [ query>> ] bi count ;
|
||||
Loading…
Reference in New Issue