extra/mongodb/tuple/tuple.factor

   1 USING: accessors assocs classes.mixin classes.tuple
   2 classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
   3 mongodb.msg mongodb.tuple.collection
   4 mongodb.tuple.persistent mongodb.tuple.state strings ;
   5
   6 IN: mongodb.tuple
   7
   8 SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ +unique+ ;
   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     [ [ mdb-index-map values ] keep
  25       '[ _ name>> >>ns ensure-index ] each
  26     ] bi ;
  27
  28 : ensure-tables ( classes -- )
  29     [ ensure-table ] each ;
  30
  31 : drop-table ( class -- )
  32       tuple-collection
  33       [ [ mdb-index-map values ] keep
  34         '[ _ name>> swap name>> drop-index ] each ]
  35       [ name>> drop-collection ] bi ;
  36
  37 : recreate-table ( class -- )
  38     [ drop-table ]
  39     [ ensure-table ] bi ;
  40
  41 <PRIVATE
  42
  43 GENERIC: id-selector ( object -- selector )
  44
  45 M: toid id-selector
  46    [ value>> ] [ key>> ] bi H{ } clone [ set-at ] keep ; inline
  47
  48 M: mdb-persistent id-selector
  49    >toid id-selector ;
  50
  51 : (save-tuples) ( collection assoc -- )
  52    swap '[ [ _ ] 2dip
  53            [ id-selector ] dip
  54            <update> >upsert update ] assoc-each ; inline
  55 PRIVATE>
  56
  57 : save-tuple-deep ( tuple -- )
  58     tuple>storable [ (save-tuples) ] assoc-each ;
  59
  60 : update-tuple ( tuple -- )
  61     [ tuple-collection name>> ]
  62     [ id-selector ]
  63     [ tuple>assoc ] tri
  64     <update> update ;
  65
  66 : save-tuple ( tuple -- )
  67     update-tuple ;
  68
  69 : insert-tuple ( tuple -- )
  70    [ tuple-collection name>> ]
  71    [ tuple>assoc ] bi
  72    save ;
  73
  74 : delete-tuple ( tuple -- )
  75    [ tuple-collection name>> ] keep
  76    id-selector delete ;
  77
  78 : delete-tuples ( seq -- )
  79     [ delete-tuple ] each ;
  80
  81 : tuple>query ( tuple -- query )
  82    [ tuple-collection name>> ] keep
  83    tuple>selector <query> ;
  84
  85 : select-tuple ( tuple/query -- tuple/f )
  86    dup mdb-query-msg? [ tuple>query ] unless
  87    find-one [ assoc>tuple ] [ f ] if* ;
  88
  89 : select-tuples ( tuple/query -- cursor tuples/f )
  90    dup mdb-query-msg? [ tuple>query ] unless
  91    find [ assoc>tuple ] map ;
  92
  93 : count-tuples ( tuple/query -- n )
  94    dup mdb-query-msg? [ tuple>query ] unless count ;