extra/mongodb/tuple/persistent/persistent.factor

   1 USING: accessors assocs bson.constants combinators.short-circuit
   2 constructors continuations fry kernel mirrors mongodb.tuple.collection
   3 mongodb.tuple.state namespaces sequences words bson.writer combinators
   4 hashtables linked-assocs ;
   5
   6 IN: mongodb.tuple.persistent
   7
   8 SYMBOLS: object-map ;
   9
  10 GENERIC: tuple>assoc ( tuple -- assoc )
  11
  12 GENERIC: tuple>selector ( tuple -- selector )
  13
  14 DEFER: assoc>tuple
  15
  16 <PRIVATE
  17
  18 : mdbinfo>tuple-class ( tuple-info -- class )
  19    [ first ] keep second lookup ; inline
  20
  21 : tuple-instance ( tuple-info -- instance )
  22     mdbinfo>tuple-class new ; inline
  23
  24 : prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
  25    [ tuple-info tuple-instance dup
  26      <mirror> [ keys ] keep ] keep swap ; inline
  27
  28 : make-tuple ( assoc -- tuple )
  29    prepare-assoc>tuple
  30    '[ dup _ at assoc>tuple swap _ set-at ] each
  31    [ mark-persistent ] keep ; inline recursive
  32
  33 : at+ ( value key assoc -- value )
  34     2dup key?
  35     [ at nip ] [ [ dup ] 2dip set-at ] if ; inline
  36
  37 : data-tuple? ( tuple -- ? )
  38     dup tuple?
  39     [ assoc? not ] [ drop f ] if  ; inline
  40
  41 : add-storable ( assoc ns -- )
  42    [ H{ } clone ] dip object-map get at+
  43    [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
  44
  45 : write-field? ( tuple key value -- ? )
  46    pick mdb-persistent? [
  47       { [ [ 2drop ] dip not ]
  48         [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
  49
  50 TUPLE: cond-value value quot ;
  51
  52 CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
  53
  54 : write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
  55    over [ (( tuple -- assoc )) call-effect ] dip
  56    [ tuple-collection name>> ] keep
  57    [ add-storable ] dip
  58    [ tuple-collection name>> ] [ _id>> ] bi <objref> ; inline
  59
  60 : write-field ( value quot: ( tuple -- assoc ) -- value' )
  61    <cond-value> {
  62       { [ dup value>> mdb-special-value? ] [ value>> ]  }
  63       { [ dup value>> mdb-persistent? ]
  64         [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
  65       { [ dup value>> data-tuple? ]
  66         [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ]  }
  67       { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
  68         [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
  69       [ value>> ]
  70    } cond ; inline recursive
  71
  72 : write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
  73    swap ! m t q q a
  74    '[ _ 2over write-field?
  75       [ _ write-field swap _ set-at ]
  76       [ 2drop ] if
  77    ] assoc-each ;
  78
  79 : prepare-assoc ( tuple -- assoc mirror tuple assoc )
  80    H{ } clone swap [ <mirror> ] keep pick ; inline
  81
  82 : ensure-mdb-info ( tuple -- tuple )
  83    dup _id>> [ <objid> >>_id ] unless
  84    [ mark-persistent ] keep ; inline
  85
  86 : with-object-map ( quot: ( -- ) -- store-assoc )
  87    [ H{ } clone dup object-map ] dip with-variable ; inline
  88
  89 : (tuple>assoc) ( tuple -- assoc )
  90    [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
  91    over set-tuple-info ; inline
  92
  93 PRIVATE>
  94
  95 GENERIC: tuple>storable ( tuple -- storable )
  96
  97 M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
  98    '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
  99
 100 M: mdb-persistent tuple>assoc ( tuple -- assoc )
 101    ensure-mdb-info (tuple>assoc) ;
 102
 103 M: tuple tuple>assoc ( tuple -- assoc )
 104    (tuple>assoc) ;
 105
 106 M: tuple tuple>selector ( tuple -- assoc )
 107     prepare-assoc [ tuple>selector ] write-tuple-fields ;
 108
 109 : assoc>tuple ( assoc -- tuple )
 110     dup assoc?
 111     [ [ dup tuple-info?
 112         [ make-tuple ]
 113         [ ] if ] [ drop ] recover
 114     ] [ ] if ; inline recursive
 115