extra/mongodb/tuple/tuple.factor

   1 USING: accessors assocs classes.mixin classes.tuple
   2 classes.tuple.parser compiler.units hashtables kernel
   3 mongodb.driver mongodb.msg mongodb.tuple.collection
   4 mongodb.tuple.persistent sequences ;
   5 FROM: mongodb.driver => update delete find count ;
   6 FROM: mongodb.tuple.persistent => assoc>tuple ;
   7
   8 IN: mongodb.tuple
   9
  10 SYNTAX: MDBTUPLE:
  11     parse-tuple-definition
  12     mdb-check-slots
  13     define-tuple-class ;
  14
  15 : define-persistent ( class collection slot-options index -- )
  16     [ [ <mdb-tuple-collection> dupd link-collection ] when* ] 2dip
  17     [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] 2dip
  18     [ drop set-slot-map ]
  19     [ nip set-index-map ] 3bi ; inline
  20
  21 : ensure-table ( class -- )
  22     tuple-collection
  23     [ create-collection ]
  24     [
  25         [ mdb-index-map values ] keep
  26         '[ _ name>> >>ns ensure-index ] each
  27     ] bi ;
  28
  29 : ensure-tables ( classes -- )
  30     [ ensure-table ] each ;
  31
  32 : drop-table ( class -- )
  33     tuple-collection
  34     [ [ mdb-index-map values ] keep
  35     '[ _ name>> swap name>> drop-index ] each ]
  36     [ name>> drop-collection ] bi ;
  37
  38 : recreate-table ( class -- )
  39     [ drop-table ]
  40     [ ensure-table ] bi ;
  41
  42 DEFER: tuple>query
  43
  44 <PRIVATE
  45
  46 GENERIC: id-selector ( object -- selector )
  47
  48 M: toid id-selector
  49     [ value>> ] [ key>> ] bi associate ; inline
  50
  51 M: mdb-persistent id-selector
  52     >toid id-selector ;
  53
  54 : (save-tuples) ( collection assoc -- )
  55     swap '[
  56         [ _ ] 2dip
  57         [ id-selector ] dip
  58         <update> >upsert update
  59     ] assoc-each ; inline
  60
  61 : prepare-tuple-query ( tuple/query -- query )
  62     dup mdb-query-msg? [ tuple>query ] unless ;
  63
  64 PRIVATE>
  65
  66 : save-tuple-deep ( tuple -- )
  67     tuple>storable [ (save-tuples) ] assoc-each ;
  68
  69 : update-tuple ( tuple -- )
  70     [ tuple-collection name>> ]
  71     [ ensure-oid id-selector ]
  72     [ tuple>assoc ] tri
  73     <update> >upsert update ;
  74
  75 : save-tuple ( tuple -- )
  76     update-tuple ;
  77
  78 : insert-tuple ( tuple -- )
  79     [ tuple-collection name>> ]
  80     [ tuple>assoc ] bi
  81     save ;
  82
  83 : delete-tuple ( tuple -- )
  84     [ tuple-collection name>> ] keep
  85     id-selector <delete> delete ;
  86
  87 : delete-tuples ( seq -- )
  88     [ delete-tuple ] each ;
  89
  90 : tuple>query ( tuple -- query )
  91     [ tuple-collection name>> ] keep
  92     tuple>selector <query> ;
  93
  94 : select-tuple ( tuple/query -- tuple/f )
  95     prepare-tuple-query
  96     find-one [ assoc>tuple ] [ f ] if* ;
  97
  98 : select-tuples ( tuple/query -- cursor tuples/f )
  99     prepare-tuple-query
 100     find [ assoc>tuple ] map ;
 101
 102 : select-all-tuples ( tuple/query -- tuples )
 103     prepare-tuple-query
 104     find-all [ assoc>tuple ] map ;
 105
 106 : count-tuples ( tuple/query -- n )
 107     dup mdb-query-msg? [ tuple>query ] unless count ;