extra/mongodb/tuple/index/index.factor

   1 USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
   2 mongodb.tuple.collection combinators mongodb.tuple.collection ;
   3
   4 IN: mongodb.tuple
   5
   6 SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
   7
   8 IN: mongodb.tuple.index
   9
  10 TUPLE: tuple-index name spec ;
  11
  12 <PRIVATE
  13
  14 : index-type ( type -- name )
  15     { { +fieldindex+ [ "field" ] }
  16       { +deepindex+ [ "deep" ] }
  17       { +compoundindex+ [ "compound" ] } } case ;
  18
  19 : index-name ( slot index-spec -- name )
  20     [ first index-type ] keep
  21     rest "-" join
  22     "%s-%s-%s-Idx" sprintf ;
  23
  24 : build-index ( element slot -- assoc )
  25     swap [ <linked-hash> ] 2dip
  26     [ rest ] keep first ! assoc slot options itype
  27     { { +fieldindex+ [ drop [ 1 ] dip pick set-at  ] }
  28       { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] }
  29       { +compoundindex+ [
  30           2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options
  31           over '[ _ [ 1 ] 2dip set-at ] each ] }
  32     } case ;
  33
  34 : build-index-seq ( slot optlist -- index-seq )
  35     [ V{ } clone ] 2dip pick  ! v{} slot optl v{}
  36     [ swap ] dip  ! v{} optl slot v{ }
  37     '[ _ tuple-index new ! element slot exemplar
  38        2over swap index-name >>name  ! element slot clone
  39        [ build-index ] dip swap >>spec _ push
  40     ] each ;
  41
  42 : is-index-declaration? ( entry -- ? )
  43     first
  44     { { +fieldindex+ [ t ] }
  45       { +compoundindex+ [ t ] }
  46       { +deepindex+ [ t ] }
  47       [ drop f ] } case ;
  48
  49 PRIVATE>
  50
  51 : tuple-index-list ( mdb-collection/class -- seq )
  52     mdb-slot-map V{ } clone tuck
  53     '[ [ is-index-declaration? ] filter
  54        build-index-seq _ push
  55     ] assoc-each flatten ;
  56