basis/ui/gadgets/slots/slots.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors namespaces kernel parser prettyprint
   4 sequences arrays io math definitions math.vectors assocs refs
   5 ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
   6 ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
   7 ui.gadgets.editors eval ;
   8 IN: ui.gadgets.slots
   9
  10 TUPLE: update-object ;
  11
  12 TUPLE: update-slot ;
  13
  14 TUPLE: edit-slot ;
  15
  16 TUPLE: slot-editor < track ref text ;
  17
  18 : revert ( slot-editor -- )
  19     dup ref>> get-ref unparse-use
  20     swap text>> set-editor-string ;
  21
  22 \ revert H{
  23     { +description+ "Revert any uncomitted changes." }
  24 } define-command
  25
  26 GENERIC: finish-editing ( slot-editor ref -- )
  27
  28 M: key-ref finish-editing
  29     drop T{ update-object } swap send-gesture drop ;
  30
  31 M: value-ref finish-editing
  32     drop T{ update-slot } swap send-gesture drop ;
  33
  34 : slot-editor-value ( slot-editor -- object )
  35     text>> control-value parse-fresh ;
  36
  37 : commit ( slot-editor -- )
  38     dup text>> control-value parse-fresh first
  39     over ref>> set-ref
  40     dup ref>> finish-editing ;
  41
  42 \ commit H{
  43     { +description+ "Parse the object being edited, and store the result back into the edited slot." }
  44 } define-command
  45
  46 : com-eval ( slot-editor -- )
  47     [ text>> editor-string eval ] keep
  48     [ ref>> set-ref ] keep
  49     dup ref>> finish-editing ;
  50
  51 \ com-eval H{
  52     { +listener+ t }
  53     { +description+ "Parse code which evaluates to an object, and store the result back into the edited slot." }
  54 } define-command
  55
  56 : delete ( slot-editor -- )
  57     dup ref>> delete-ref
  58     T{ update-object } swap send-gesture drop ;
  59
  60 \ delete H{
  61     { +description+ "Delete the slot and close the slot editor." }
  62 } define-command
  63
  64 : close ( slot-editor -- )
  65     T{ update-slot } swap send-gesture drop ;
  66
  67 \ close H{
  68     { +description+ "Close the slot editor without saving changes." }
  69 } define-command
  70
  71 : <slot-editor> ( ref -- gadget )
  72     { 0 1 } slot-editor new-track
  73         swap >>ref
  74         dup <toolbar> f track-add
  75         <source-editor> >>text
  76         dup text>> <scroller> 1 track-add
  77         dup revert ;
  78
  79 M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
  80
  81 M: slot-editor focusable-child* text>> ;
  82
  83 slot-editor "toolbar" f {
  84     { T{ key-down f { C+ } "RET" } commit }
  85     { T{ key-down f { S+ C+ } "RET" } com-eval }
  86     { f revert }
  87     { f delete }
  88     { T{ key-down f f "ESC" } close }
  89 } define-command-map
  90
  91 TUPLE: editable-slot < track printer ref ;
  92
  93 : <edit-button> ( -- gadget )
  94     "..."
  95     [ T{ edit-slot } swap send-gesture drop ]
  96     <roll-button> ;
  97
  98 : display-slot ( gadget editable-slot -- )
  99   dup clear-track
 100     swap          1 track-add
 101     <edit-button> f track-add
 102   drop ;
 103
 104 : update-slot ( editable-slot -- )
 105     [ [ ref>> get-ref ] [ printer>> ] bi call ] keep
 106     display-slot ;
 107
 108 : edit-slot ( editable-slot -- )
 109     [ clear-track ]
 110     [
 111         dup ref>> <slot-editor>
 112         [ 1 track-add drop ]
 113         [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
 114     ] bi ;
 115
 116 \ editable-slot H{
 117     { T{ update-slot } [ update-slot ] }
 118     { T{ edit-slot } [ edit-slot ] }
 119 } set-gestures
 120
 121 : <editable-slot> ( gadget ref -- editable-slot )
 122     { 1 0 } editable-slot new-track
 123         swap >>ref
 124         [ drop <gadget> ] >>printer
 125         [ display-slot ] keep ;