reworked primary key handling and define-persistent for tuples

diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor
index a4f86cd6a3be1d9f845f1f92dd243b4ba83aa8fa..1bd2d94e69c865432577fc3a9a8b4053ae0feadd 100644 (file)
--- a/extra/mongodb/tuple/collection/collection.factor
+++ b/extra/mongodb/tuple/collection/collection.factor
@@ -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? ;
 

diff --git a/extra/mongodb/tuple/index/authors.txt b/extra/mongodb/tuple/index/authors.txt
deleted file mode 100644 (file)
index 5df962b..0000000
--- a/extra/mongodb/tuple/index/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Sascha Matzke

diff --git a/extra/mongodb/tuple/index/index.factor b/extra/mongodb/tuple/index/index.factor
deleted file mode 100644 (file)
index 1e7a679..0000000
--- a/extra/mongodb/tuple/index/index.factor
+++ /dev/null
@@ -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 ;
-

diff --git a/extra/mongodb/tuple/index/summary.txt b/extra/mongodb/tuple/index/summary.txt
deleted file mode 100644 (file)
index e4a1549..0000000
--- a/extra/mongodb/tuple/index/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-tuple class index handling

diff --git a/extra/mongodb/tuple/persistent/persistent.factor b/extra/mongodb/tuple/persistent/persistent.factor
index 061b27dd1bd80f62c45b47d5581f9c7a2a9413f7..fc521eca3ef375378e5d846c19fe3629d29d198b 100644 (file)
--- a/extra/mongodb/tuple/persistent/persistent.factor
+++ b/extra/mongodb/tuple/persistent/persistent.factor
@@ -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
 

diff --git a/extra/mongodb/tuple/state/state.factor b/extra/mongodb/tuple/state/state.factor
index 21923637e5421ca1f8154afcec33a031f23139e8..ec1b8865ab2c8be470f95872f5ae885cb34f3445 100644 (file)
--- a/extra/mongodb/tuple/state/state.factor
+++ b/extra/mongodb/tuple/state/state.factor
@@ -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 ;
-

diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
index 19281b769ae9af930b9f1ee6d1cd52c37bfa4d7d..cbde30ca806fc4855d45e11550ef1aab4f7ec12d 100644 (file)
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@@ -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