extra/mongodb/tuple/persistent/persistent.factor

   1 USING: accessors assocs bson.constants bson.writer combinators
   2 combinators.short-circuit constructors continuations hashtables
   3 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     [ { [ 2nip not ] [ drop transient-slot? ] } 3|| not ]
  46     [ 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 a
  72     '[
  73         _ 2over write-field?
  74         [ _ write-field swap _ set-at ]
  75         [ 2drop ] if
  76     ] assoc-each ;
  77
  78 : prepare-assoc ( tuple -- assoc mirror tuple assoc )
  79     H{ } clone swap [ <mirror> ] keep pick ; inline
  80
  81 : with-object-map ( quot: ( -- ) -- store-assoc )
  82     [ H{ } clone dup object-map ] dip with-variable ; inline
  83
  84 : (tuple>assoc) ( tuple -- assoc )
  85     [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
  86     over set-tuple-info ; inline
  87
  88 PRIVATE>
  89
  90 GENERIC: tuple>storable ( tuple -- storable )
  91
  92 : ensure-oid ( tuple -- tuple )
  93     dup id>> [ <oid> >>id ] unless ; inline
  94
  95 M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
  96     '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
  97
  98 M: mdb-persistent tuple>assoc ( tuple -- assoc )
  99     ensure-oid (tuple>assoc) ;
 100
 101 M: tuple tuple>assoc ( tuple -- assoc )
 102     (tuple>assoc) ;
 103
 104 M: tuple tuple>selector ( tuple -- assoc )
 105     prepare-assoc [ tuple>selector ] write-tuple-fields ;
 106
 107 : assoc>tuple ( assoc -- tuple )
 108     dup assoc? [
 109         [ dup tuple-info? [ make-tuple ] when ] ignore-errors
 110     ] when ; inline recursive