steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'mongo-factor-driver' of git://github.com/x6j8x/factor

db4
Slava Pestov 2009-05-04 05:18:17 -05:00
parent b4088373b7 28fa05858f
commit 61711b6d59
8 changed files with 113 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/mongodb/driver/driver.factor
View File

@ -178,7 +178,7 @@ M: mdb-query-msg skip
GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
M: mdb-query-msg sort
output>array >>orderby ; inline
output>array [ 1array >hashtable ] map >>orderby ; inline
: key-spec ( spec-quot -- spec-assoc )
output>array >hashtable ; inline

105
extra/mongodb/tuple/collection/collection.factor
View File

@ -1,51 +1,96 @@
USING: accessors arrays assocs bson.constants classes classes.tuple
combinators continuations fry kernel mongodb.driver sequences strings
vectors words combinators.smart literals ;
vectors words combinators.smart literals memoize slots constructors ;
IN: mongodb.tuple
SINGLETONS: +transient+ +load+ ;
SINGLETONS: +transient+ +load+ +user-defined-key+ ;
: <tuple-index> ( name key -- index-spec )
index-spec new swap >>key swap >>name ;
IN: mongodb.tuple.collection
FROM: mongodb.tuple => +transient+ +load+ ;
TUPLE: toid key value ;
CONSTRUCTOR: toid ( value key -- toid ) ;
FROM: mongodb.tuple => +transient+ +load+ <tuple-index> ;
MIXIN: mdb-persistent
SLOT: id
SLOT: _id
SLOT: _mfd
<PRIVATE
CONSTANT: MDB_COLLECTION "mongodb_collection"
CONSTANT: MDB_SLOTDEF_MAP "mongodb_slot_map"
CONSTANT: MDB_INDEX_MAP "mongodb_index_map"
CONSTANT: MDB_USER_KEY "mongodb_user_key"
CONSTANT: MDB_COLLECTION_MAP "mongodb_collection_map"
MEMO: id-slot ( class -- slot )
MDB_USER_KEY word-prop
dup [ drop "_id" ] unless ;
PRIVATE>
: >toid ( object -- toid )
[ id>> ] [ class id-slot ] bi <toid> ;
M: mdb-persistent id>> ( object -- id )
dup class id-slot reader-word execute( object -- id ) ;
M: mdb-persistent (>>id) ( object value -- )
over class id-slot writer-word execute( object value -- ) ;
TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
GENERIC: tuple-collection ( object -- mdb-collection )
GENERIC: mdb-slot-map ( tuple -- string )
GENERIC: mdb-slot-map ( tuple -- assoc )
GENERIC: mdb-index-map ( tuple -- sequence )
<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-map) ( class -- slot-defs )
superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
: (mdb-slot-map) ( class -- slot-map )
superclasses [ MDB_SLOTDEF_MAP word-prop ] map assoc-combine ; inline
: (mdb-index-map) ( class -- index-map )
superclasses [ MDB_INDEX_MAP 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
[ H{ } clone ] dip over
'[ split-optl swap _ set-at ] each ; inline
: index-list>map ( seq -- map )
[ H{ } clone ] dip over
'[ dup name>> _ set-at ] each ; inline
: user-defined-key ( map -- key value ? )
[ nip [ +user-defined-key+ ] dip member? ] assoc-find ; inline
: user-defined-key-index ( class -- assoc )
mdb-slot-map user-defined-key
[ drop [ "user-defined-key-index" 1 ] dip
H{ } clone [ set-at ] keep <tuple-index> unique-index
[ ] [ name>> ] bi H{ } clone [ set-at ] keep
] [ 2drop H{ } clone ] if ;
PRIVATE>
@ -65,9 +110,15 @@ PRIVATE>
over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
[ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
: set-slot-map ( class options -- )
optl>map MDB_SLOTDEF_LIST set-word-prop ; inline
: set-slot-map ( class option-list -- )
optl>map [ MDB_SLOTDEF_MAP set-word-prop ] 2keep
user-defined-key
[ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
: set-index-map ( class index-list -- )
[ [ dup user-defined-key-index ] dip index-list>map ] output>sequence
assoc-combine MDB_INDEX_MAP set-word-prop ; inline
M: tuple-class tuple-collection ( tuple -- mdb-collection )
(mdb-collection) ;
@ -83,6 +134,13 @@ M: tuple-class mdb-slot-map ( class -- assoc )
M: mdb-collection mdb-slot-map ( collection -- assoc )
classes>> [ mdb-slot-map ] map assoc-combine ;
M: mdb-persistent mdb-index-map
class (mdb-index-map) ;
M: tuple-class mdb-index-map
(mdb-index-map) ;
M: mdb-collection mdb-index-map
classes>> [ mdb-index-map ] map assoc-combine ;
<PRIVATE
: collection-map ( -- assoc )
@ -92,17 +150,17 @@ M: mdb-collection mdb-slot-map ( collection -- assoc )
: slot-option? ( tuple slot option -- ? )
[ swap mdb-slot-map at ] dip
'[ _ swap key? ] [ f ] if* ;
'[ _ swap memq? ] [ f ] if* ;
PRIVATE>
GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
M: string <mdb-tuple-collection> ( name -- mdb-tuple-collection )
M: string <mdb-tuple-collection>
collection-map [ ] [ key? ] 2bi
[ at ] [ [ mdb-tuple-collection new dup ] 2dip
[ [ >>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 )
M: mdb-tuple-collection <mdb-tuple-collection> ;
M: mdb-collection <mdb-tuple-collection>
[ name>> <mdb-tuple-collection> ] keep
{
[ capped>> >>capped ]
@ -110,6 +168,9 @@ M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collectio
[ max>> >>max ]
} cleave ;
: user-defined-key? ( tuple slot -- ? )
+user-defined-key+ slot-option? ;
: transient-slot? ( tuple slot -- ? )
+transient+ slot-option? ;

1
extra/mongodb/tuple/index/authors.txt
View File

@ -1 +0,0 @@
Sascha Matzke

56
extra/mongodb/tuple/index/index.factor
View File

@ -1,56 +0,0 @@
USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
mongodb.tuple.collection combinators mongodb.tuple.collection ;
IN: mongodb.tuple
SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
IN: mongodb.tuple.index
TUPLE: tuple-index name spec ;
<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-map V{ } clone tuck
'[ [ is-index-declaration? ] filter
build-index-seq _ push
] assoc-each flatten ;

1
extra/mongodb/tuple/index/summary.txt
View File

@ -1 +0,0 @@
tuple class index handling

28
extra/mongodb/tuple/persistent/persistent.factor
View File

@ -27,8 +27,7 @@ DEFER: assoc>tuple
: make-tuple ( assoc -- tuple )
prepare-assoc>tuple
'[ dup _ at assoc>tuple swap _ set-at ] each
[ mark-persistent ] keep ; inline recursive
'[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive
: at+ ( value key assoc -- value )
2dup key?
@ -38,9 +37,9 @@ DEFER: assoc>tuple
dup tuple?
[ assoc? not ] [ drop f ] if ; inline
: add-storable ( assoc ns -- )
[ H{ } clone ] dip object-map get at+
[ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
: add-storable ( assoc ns toid -- )
[ [ H{ } clone ] dip object-map get at+ ] dip
swap set-at ; inline
: write-field? ( tuple key value -- ? )
pick mdb-persistent? [
@ -52,10 +51,10 @@ TUPLE: cond-value value quot ;
CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
over [ (( tuple -- assoc )) call-effect ] dip
[ tuple-collection name>> ] keep
over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip
[ tuple-collection name>> ] [ _id>> ] bi <objref> ; inline
[ tuple-collection name>> ] [ id>> ] bi <objref> ; inline
: write-field ( value quot: ( tuple -- assoc ) -- value' )
<cond-value> {
@ -80,8 +79,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
H{ } clone swap [ <mirror> ] keep pick ; inline
: ensure-mdb-info ( tuple -- tuple )
dup _id>> [ <objid> >>_id ] unless
[ mark-persistent ] keep ; inline
dup id>> [ <objid> >>id ] unless ; inline
: with-object-map ( quot: ( -- ) -- store-assoc )
[ H{ } clone dup object-map ] dip with-variable ; inline
@ -107,9 +105,9 @@ 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 recursive
dup assoc?
[ [ dup tuple-info?
[ make-tuple ]
[ ] if ] [ drop ] recover
] [ ] if ; inline recursive

27
extra/mongodb/tuple/state/state.factor
View File

@ -6,17 +6,9 @@ IN: mongodb.tuple.state
<PRIVATE
CONSTANT: MDB_TUPLE_INFO "_mfd_t_info"
CONSTANT: MDB_DIRTY_FLAG "d?"
CONSTANT: MDB_PERSISTENT_FLAG "p?"
CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set"
PRIVATE>
SYMBOL: mdb-dirty-handling?
: advised-with? ( name word loc -- ? )
word-prop key? ; inline
: <tuple-info> ( tuple -- tuple-info )
class V{ } clone tuck
[ [ name>> ] dip push ]
@ -31,22 +23,3 @@ SYMBOL: mdb-dirty-handling?
: 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 ] dip tuple-meta at ;
: mark-dirty ( tuple -- )
[ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
: persistent? ( tuple -- ? )
[ MDB_PERSISTENT_FLAG ] dip tuple-meta at ;
: mark-persistent ( tuple -- )
[ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep
[ f MDB_DIRTY_FLAG ] dip set-at ;
: needs-store? ( tuple -- ? )
[ persistent? not ] [ dirty? ] bi or ;

31
extra/mongodb/tuple/tuple.factor
View File

@ -5,22 +5,24 @@ mongodb.tuple.persistent mongodb.tuple.state strings ;
IN: mongodb.tuple
SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ +unique+ ;
SYNTAX: MDBTUPLE:
parse-tuple-definition
mdb-check-slots
define-tuple-class ;
: define-persistent ( class collection options -- )
[ [ <mdb-tuple-collection> dupd link-collection ] when* ] dip
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
! [ dup annotate-writers ] dip
set-slot-map ;
: define-persistent ( class collection slot-options index -- )
[ [ <mdb-tuple-collection> dupd link-collection ] when* ] 2dip
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] 2dip
[ drop set-slot-map ]
[ nip set-index-map ] 3bi ; inline
: ensure-table ( class -- )
tuple-collection
[ create-collection ]
[ [ tuple-index-list ] keep
'[ _ name>> swap [ name>> ] [ spec>> ] bi <index-spec> ensure-index ] each
[ [ mdb-index-map values ] keep
'[ _ name>> >>ns ensure-index ] each
] bi ;
: ensure-tables ( classes -- )
@ -28,7 +30,7 @@ SYNTAX: MDBTUPLE:
: drop-table ( class -- )
tuple-collection
[ [ tuple-index-list ] keep
[ [ mdb-index-map values ] keep
'[ _ name>> swap name>> drop-index ] each ]
[ name>> drop-collection ] bi ;
@ -40,11 +42,11 @@ SYNTAX: MDBTUPLE:
GENERIC: id-selector ( object -- selector )
M: string id-selector ( objid -- selector )
"_id" H{ } clone [ set-at ] keep ; inline
M: toid id-selector
[ value>> ] [ key>> ] bi H{ } clone [ set-at ] keep ; inline
M: mdb-persistent id-selector ( mdb-persistent -- selector )
_id>> id-selector ;
M: mdb-persistent id-selector
>toid id-selector ;
: (save-tuples) ( collection assoc -- )
swap '[ [ _ ] 2dip
@ -62,9 +64,8 @@ PRIVATE>
save-tuple ;
: delete-tuple ( tuple -- )
dup persistent?
[ [ tuple-collection name>> ] keep
id-selector delete ] [ drop ] if ;
[ tuple-collection name>> ] keep
id-selector delete ;
: tuple>query ( tuple -- query )
[ tuple-collection name>> ] keep