extra/mongodb/tuple/persistent/persistent.factor

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