extra/mongodb/tuple/collection/collection.factor

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