extra/mongodb/tuple/collection/collection.factor

   1 USING: accessors arrays assocs bson.constants classes classes.tuple
   2 combinators continuations fry kernel mongodb.driver sequences strings
   3 vectors words combinators.smart literals memoize slots constructors
   4 hashtables ;
   5
   6 IN: mongodb.tuple
   7
   8 SINGLETONS: +transient+ +load+ +user-defined-key+ ;
   9
  10 : <tuple-index> ( name key -- index-spec )
  11     index-spec new swap >>key swap >>name ;
  12
  13 IN: mongodb.tuple.collection
  14
  15 TUPLE: toid key value ;
  16
  17 CONSTRUCTOR: <toid> toid ( value key -- toid ) ;
  18
  19 FROM: mongodb.tuple => +transient+ +load+ <tuple-index> ;
  20
  21 MIXIN: mdb-persistent
  22
  23 SLOT: id
  24 SLOT: _id
  25 SLOT: _mfd
  26
  27 <PRIVATE
  28
  29 CONSTANT: MDB_COLLECTION     "mongodb_collection"
  30 CONSTANT: MDB_SLOTDEF_MAP    "mongodb_slot_map"
  31 CONSTANT: MDB_INDEX_MAP      "mongodb_index_map"
  32 CONSTANT: MDB_USER_KEY       "mongodb_user_key"
  33 CONSTANT: MDB_COLLECTION_MAP "mongodb_collection_map"
  34
  35 MEMO: id-slot ( class -- slot )
  36    MDB_USER_KEY word-prop
  37    dup [ drop "_id" ] unless ;
  38
  39 PRIVATE>
  40
  41 : >toid ( object -- toid )
  42    [ id>> ] [ class-of id-slot ] bi <toid> ;
  43
  44 M: mdb-persistent id>> ( object -- id )
  45    dup class-of id-slot reader-word execute( object -- id ) ;
  46
  47 M: mdb-persistent id<< ( object value -- )
  48    over class-of id-slot writer-word execute( object value -- ) ;
  49
  50
  51
  52 TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
  53
  54 GENERIC: tuple-collection ( object -- mdb-collection )
  55
  56 GENERIC: mdb-slot-map  ( tuple -- assoc )
  57
  58 GENERIC: mdb-index-map ( tuple -- sequence )
  59
  60 <PRIVATE
  61
  62
  63 : (mdb-collection) ( class -- mdb-collection )
  64     dup MDB_COLLECTION word-prop
  65     [ nip ]
  66     [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
  67
  68 : (mdb-slot-map) ( class -- slot-map )
  69     superclasses [ MDB_SLOTDEF_MAP word-prop ] map assoc-combine  ; inline
  70
  71 : (mdb-index-map) ( class -- index-map )
  72     superclasses [ MDB_INDEX_MAP word-prop ] map assoc-combine ; inline
  73
  74 : split-optl ( seq -- key options )
  75     [ first ] [ rest ] bi ; inline
  76
  77 : optl>map ( seq -- map )
  78     [ H{ } clone ] dip over
  79     '[ split-optl swap _ set-at ] each ; inline
  80
  81 : index-list>map ( seq -- map )
  82     [ H{ } clone ] dip over
  83     '[ dup name>> _ set-at ] each ; inline
  84
  85 : user-defined-key ( map -- key value ? )
  86     [ nip [ +user-defined-key+ ] dip member? ] assoc-find ; inline
  87
  88 : user-defined-key-index ( class -- assoc )
  89     mdb-slot-map user-defined-key
  90     [ drop [ "user-defined-key-index" 1 ] dip
  91       associate <tuple-index> t >>unique?
  92       [ ] [ name>> ] bi associate
  93     ] [ 2drop H{ } clone ] if ;
  94
  95
  96
  97 PRIVATE>
  98
  99 : MDB_ADDON_SLOTS ( -- slots )
 100    { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
 101
 102 : link-class ( collection class -- )
 103     over classes>>
 104     [ 2dup member? [ 2drop ] [ push ] if ]
 105     [ 1vector >>classes ] if* drop ; inline
 106
 107 : link-collection ( class collection -- )
 108     [ swap link-class ]
 109     [ MDB_COLLECTION set-word-prop ] 2bi ; inline
 110
 111 : mdb-check-slots ( superclass slots -- superclass slots )
 112     over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
 113     [  ] [ MDB_ADDON_SLOTS prepend ] if ; inline
 114
 115 : set-slot-map ( class option-list -- )
 116     optl>map [ MDB_SLOTDEF_MAP set-word-prop ] 2keep
 117     user-defined-key
 118     [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
 119
 120 : set-index-map ( class index-list -- )
 121     [ dup user-defined-key-index ] dip index-list>map 2array
 122     assoc-combine MDB_INDEX_MAP set-word-prop ; inline
 123
 124 M: tuple-class tuple-collection ( tuple -- mdb-collection )
 125     (mdb-collection) ;
 126
 127 M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
 128     class-of (mdb-collection) ;
 129
 130 M: mdb-persistent mdb-slot-map ( tuple -- string )
 131     class-of (mdb-slot-map) ;
 132
 133 M: tuple-class mdb-slot-map ( class -- assoc )
 134     (mdb-slot-map) ;
 135
 136 M: mdb-collection mdb-slot-map ( collection -- assoc )
 137     classes>> [ mdb-slot-map ] map assoc-combine ;
 138
 139 M: mdb-persistent mdb-index-map
 140     class-of (mdb-index-map) ;
 141 M: tuple-class mdb-index-map
 142     (mdb-index-map) ;
 143 M: mdb-collection mdb-index-map
 144     classes>> [ mdb-index-map ] map assoc-combine ;
 145
 146 <PRIVATE
 147
 148 : collection-map ( -- assoc )
 149     mdb-persistent MDB_COLLECTION_MAP word-prop
 150     [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
 151       [ set-word-prop ] keep ] unless* ; inline
 152
 153 : slot-option? ( tuple slot option -- ? )
 154     [ swap mdb-slot-map at ] dip
 155     '[ _ swap member-eq? ] [ f ] if* ;
 156
 157 PRIVATE>
 158
 159 GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
 160 M: string <mdb-tuple-collection>
 161     collection-map [ ] [ key? ] 2bi
 162     [ at ] [ [ mdb-tuple-collection new dup ] 2dip
 163              [ [ >>name ] keep ] dip set-at ] if ; inline
 164 M: mdb-tuple-collection <mdb-tuple-collection> ;
 165 M: mdb-collection <mdb-tuple-collection>
 166     [ name>> <mdb-tuple-collection> ] keep
 167     {
 168         [ capped>> >>capped ]
 169         [ size>> >>size ]
 170         [ max>> >>max ]
 171     } cleave ;
 172
 173 : user-defined-key? ( tuple slot -- ? )
 174     +user-defined-key+ slot-option? ;
 175
 176 : transient-slot? ( tuple slot -- ? )
 177     +transient+ slot-option? ;
 178
 179 : load-slot? ( tuple slot -- ? )
 180     +load+ slot-option? ;