extra/ui/frp/gadgets/gadgets.factor

   1 USING: accessors assocs arrays kernel models monads sequences
   2 ui.frp.signals ui.gadgets ui.gadgets.borders ui.gadgets.buttons
   3 ui.gadgets.buttons.private ui.gadgets.editors words images.loader
   4 ui.gadgets.scrollers ui.gadgets.tables ui.images vocabs.parser lexer ;
   5 IN: ui.frp.gadgets
   6
   7 TUPLE: frp-button < button hook value ;
   8 : <frp-button> ( gadget -- button ) [
   9       [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
  10       [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
  11       [ model>> f swap (>>value) ] tri
  12    ] frp-button new-button f <basic> >>model ;
  13 : <frp-border-button> ( text -- button ) <frp-button> border-button-theme ;
  14
  15 TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
  16 M: frp-table column-titles column-titles>> ;
  17 M: frp-table column-alignment column-alignment>> ;
  18 M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
  19 M: frp-table row-value val-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
  20 M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
  21
  22 : <frp-table> ( model -- table ) f frp-table new-table dup >>renderer
  23    V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices*
  24    f <basic> >>actions dup [ actions>> set-model ] curry >>action ;
  25 : <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
  26 : <frp-list> ( column-model -- table ) <frp-table> [ 1array ] >>quot ;
  27 : <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
  28 : indexed ( table -- table ) f >>val-quot ;
  29
  30 TUPLE: frp-field < field frp-model ;
  31 : init-field ( field -- field' ) [ [ ] [ "" ] if* ] change-value ;
  32 : <frp-field> ( model -- gadget ) frp-field new-field swap init-field >>frp-model ;
  33 M: frp-field graft*
  34     [ [ frp-model>> value>> ] [ editor>> ] bi set-editor-string ]
  35     [ dup editor>> model>> add-connection ]
  36     [ dup frp-model>> add-connection ] tri ;
  37 M: frp-field ungraft*
  38    [ dup editor>> model>> remove-connection ]
  39    [ dup frp-model>> remove-connection ] bi ;
  40 M: frp-field model-changed 2dup frp-model>> =
  41     [ [ value>> ] [ editor>> ] bi* set-editor-string ]
  42     [ nip [ editor>> editor-string ] [ frp-model>> ] bi set-model ] if ;
  43
  44 : <frp-field*> ( -- field ) "" <model> <frp-field> ;
  45 : <empty-field> ( model -- field ) "" <model> <switch> <frp-field> ;
  46 : <frp-editor> ( model -- gadget )
  47     frp-field [ <multiline-editor> ] dip new-border dup gadget-child >>editor
  48     field-theme swap init-field >>frp-model { 1 0 } >>align ;
  49 : <frp-editor*> ( -- editor ) "" <model> <frp-editor> ;
  50 : <empty-editor> ( model -- editor ) "" <model> <switch> <frp-editor> ;
  51
  52 : <frp-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
  53     f <model> >>model ;
  54
  55 : image-prep ( -- quot ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround [ <image-name> ] [ load-image ] [ ] tri
  56     [ \ cached-image "memoize" word-prop set-at ] 3curry ;
  57 SYNTAX: IMG-FRP-BTN: image-prep [ <frp-button> ] append over push-all ;
  58
  59 SYNTAX: IMG-BTN: image-prep [ swap <button> ] append over push-all ;
  60
  61 GENERIC: output-model ( gadget -- model )
  62 M: gadget output-model model>> ;
  63 M: table output-model dup multiple-selection?>>
  64    [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
  65    [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
  66 M: frp-field output-model frp-model>> ;
  67 M: scroller output-model viewport>> children>> first output-model ;
  68
  69 IN: accessors
  70 M: frp-button text>> children>> first text>> ;
  71
  72 IN: ui.frp.gadgets
  73
  74 SINGLETON: gadget-monad
  75 INSTANCE: gadget-monad monad
  76 INSTANCE: gadget monad
  77 M: gadget monad-of drop gadget-monad ;
  78 M: gadget-monad return drop <gadget> swap >>model ;
  79 M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
  80
  81 ! Make sure prop removal really destroys normal db code