extra/mongodb/tuple/collection/collection.factor

   1
   2 USING: accessors arrays assocs bson.constants classes classes.tuple
   3 combinators continuations fry kernel mongodb.driver sequences strings
   4 vectors words combinators.smart literals ;
   5
   6 IN: mongodb.tuple
   7
   8 SINGLETONS: +transient+ +load+ ;
   9
  10 IN: mongodb.tuple.collection
  11
  12 FROM: mongodb.tuple => +transient+ +load+ ;
  13
  14 MIXIN: mdb-persistent
  15
  16 SLOT: _id
  17 SLOT: _mfd
  18
  19 TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
  20
  21 GENERIC: tuple-collection ( object -- mdb-collection )
  22
  23 GENERIC: mdb-slot-map  ( tuple -- string )
  24
  25 <PRIVATE
  26
  27 CONSTANT: MDB_COLLECTION     "_mdb_col"
  28 CONSTANT: MDB_SLOTDEF_LIST   "_mdb_slot_list"
  29 CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
  30
  31 : (mdb-collection) ( class -- mdb-collection )
  32     dup MDB_COLLECTION word-prop
  33     [ nip ]
  34     [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
  35
  36 : (mdb-slot-map) ( class -- slot-defs )
  37     superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine  ; inline
  38
  39 : split-optl ( seq -- key options )
  40     [ first ] [ rest ] bi ; inline
  41
  42 : opt>assoc ( seq -- assoc )
  43     [ dup assoc?
  44       [ 1array { "" } append ] unless ] map ;
  45
  46 : optl>map ( seq -- map )
  47     H{ } clone tuck
  48     '[ split-optl opt>assoc swap _ set-at ] each ; inline
  49
  50 PRIVATE>
  51
  52 : MDB_ADDON_SLOTS ( -- slots )
  53    { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
  54
  55 : link-class ( collection class -- )
  56     over classes>>
  57     [ 2dup member? [ 2drop ] [ push ] if ]
  58     [ 1vector >>classes ] if* drop ; inline
  59
  60 : link-collection ( class collection -- )
  61     [ swap link-class ]
  62     [ MDB_COLLECTION set-word-prop ] 2bi ; inline
  63
  64 : mdb-check-slots ( superclass slots -- superclass slots )
  65     over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
  66     [  ] [ MDB_ADDON_SLOTS prepend ] if ; inline
  67
  68 : set-slot-map ( class options -- )
  69     optl>map MDB_SLOTDEF_LIST set-word-prop ; inline
  70
  71 M: tuple-class tuple-collection ( tuple -- mdb-collection )
  72     (mdb-collection) ;
  73
  74 M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
  75     class (mdb-collection) ;
  76
  77 M: mdb-persistent mdb-slot-map ( tuple -- string )
  78     class (mdb-slot-map) ;
  79
  80 M: tuple-class mdb-slot-map ( class -- assoc )
  81     (mdb-slot-map) ;
  82
  83 M: mdb-collection mdb-slot-map ( collection -- assoc )
  84     classes>> [ mdb-slot-map ] map assoc-combine ;
  85
  86 <PRIVATE
  87
  88 : collection-map ( -- assoc )
  89     mdb-persistent MDB_COLLECTION_MAP word-prop
  90     [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
  91       [ set-word-prop ] keep ] unless* ; inline
  92
  93 : slot-option? ( tuple slot option -- ? )
  94     [ swap mdb-slot-map at ] dip
  95     '[ _ swap key? ] [ f ] if* ;
  96
  97 PRIVATE>
  98
  99 GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
 100 M: string <mdb-tuple-collection> ( name -- mdb-tuple-collection )
 101     collection-map [ ] [ key? ] 2bi
 102     [ at ] [ [ mdb-tuple-collection new dup ] 2dip
 103              [ [ >>name ] keep ] dip set-at ] if ; inline
 104 M: mdb-tuple-collection <mdb-tuple-collection> ( mdb-tuple-collection -- mdb-tuple-collection ) ;
 105 M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collection )
 106     [ name>> <mdb-tuple-collection> ] keep
 107     {
 108         [ capped>> >>capped ]
 109         [ size>> >>size ]
 110         [ max>> >>max ]
 111     } cleave ;
 112
 113 : transient-slot? ( tuple slot -- ? )
 114     +transient+ slot-option? ;
 115
 116 : load-slot? ( tuple slot -- ? )
 117     +load+ slot-option? ;