TUPLE: editor line caret ;
+: with-editor ( editor quot -- )
+ #! Execute a quotation in the line editor scope, then
+ #! update the display.
+ swap [ editor-line swap bind ] keep
+ dup relayout scroll>bottom ; inline
+
: editor-text ( editor -- text )
editor-line [ line-text get ] bind ;
: set-editor-text ( text editor -- )
- editor-line [ set-line-text ] bind ;
+ [ set-line-text ] with-editor ;
: focus-editor ( editor -- )
dup editor-caret swap add-gadget ;
: unfocus-editor ( editor -- )
editor-caret unparent ;
-: with-editor ( editor quot -- )
- #! Execute a quotation in the line editor scope, then
- #! update the display.
- swap [ editor-line swap bind ] keep relayout ; inline
-
: run-char-widths ( str -- wlist )
#! List of x co-ordinates of each character.
0 swap >list
shape-dim { 0 1 1 } v* { 1 0 0 } v+ ;
M: editor user-input* ( ch editor -- ? )
- [ [ insert-char ] with-editor ] keep
- scroll>bottom t ;
+ [ insert-char ] with-editor t ;
M: editor pref-dim ( editor -- dim )
dup editor-text label-size { 1 0 0 } v+ ;
DEFER: add-invalid
: invalidate ( gadget -- )
- t over set-gadget-redraw?
t swap set-gadget-relayout? ;
: relayout ( gadget -- )
#! Relayout and redraw a gadget and its parent before the
#! next iteration of the event loop.
+ dup redraw
dup gadget-relayout? [
drop
] [
TUPLE: menu ;
: menu-actions ( menu -- )
- [ drop world get hide-glass ] [ button-down 1 ] set-action ;
+ [ drop hide-glass ] [ button-down 1 ] set-action ;
: assoc>menu ( assoc menu -- )
#! Given an association list mapping labels to quotations.
#! Prepend a call to hide-menu to each quotation.
[
- uncons \ hide-menu swons <menu-item> swap add-gadget
+ uncons \ hide-glass swons <menu-item> swap add-gadget
] each-with ;
C: menu ( assoc -- gadget )
: redraw ( gadget -- )
#! Redraw a gadget before the next iteration of the event
#! loop.
- dup gadget-redraw? [
- drop
- ] [
- t over set-gadget-redraw?
- gadget-parent [ redraw ] when*
- ] ifte ;
+ drop t world get set-gadget-redraw? ;
! Clipping
[ rot "\n" split pane-write ] keep scroll>bottom ;
M: pane stream-close ( stream -- ) drop ;
-
-: <console> ( -- pane )
- <pane> <scroller> ;
: command-menu ( pane -- menu )
presented get dup applicable [
3dup third [
- [ swap literal, % ] make-list , , \ pane-call ,
+ [ swap literal, % ] make-list , ,
+ [ pane-call drop ] %
] make-list >r second r> cons
] map 2nip ;
: init-commands ( gadget pane -- )
- over presented paint-prop
- [ [ command-menu <menu> show-menu ] cons button-gestures ]
- [ 2drop ] ifte ;
+ over presented paint-prop [
+ [ drop ] swap
+ unit
+ [ command-menu <menu> show-menu ] append3
+ button-gestures
+ ] [
+ 2drop
+ ] ifte ;
: <styled-label> ( style text -- label )
<label> swap alist>hash over set-gadget-paint ;