Removing old single-line editor and updating code
slava
parent
a464c06bfd
commit
027c53b5b7
|
|
@ -189,11 +189,9 @@ sequences vectors words ;
|
|||
"/library/ui/gadgets/borders.factor"
|
||||
"/library/ui/gadgets/buttons.factor"
|
||||
"/library/ui/gadgets/tiles.factor"
|
||||
"/library/ui/gadgets/line-editor.factor"
|
||||
"/library/ui/gadgets/sliders.factor"
|
||||
"/library/ui/gadgets/viewports.factor"
|
||||
"/library/ui/gadgets/scrolling.factor"
|
||||
"/library/ui/gadgets/editors.factor"
|
||||
"/library/ui/gadgets/tracks.factor"
|
||||
"/library/ui/gadgets/incremental.factor"
|
||||
"/library/ui/gadgets/paragraphs.factor"
|
||||
|
|
@ -204,6 +202,7 @@ sequences vectors words ;
|
|||
"/library/ui/text/editor.factor"
|
||||
"/library/ui/text/commands.factor"
|
||||
"/library/ui/text/field.factor"
|
||||
"/library/ui/text/interactor.factor"
|
||||
"/library/ui/ui.factor"
|
||||
"/library/ui/gadgets/presentations.factor"
|
||||
"/library/ui/tools/listener.factor"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: objc-classes
|
|||
DEFER: FactorCallback
|
||||
|
||||
IN: cocoa
|
||||
USING: hashtables kernel namespaces objc ;
|
||||
USING: gadgets hashtables kernel namespaces objc ;
|
||||
|
||||
SYMBOL: callbacks
|
||||
|
||||
|
|
@ -15,7 +15,7 @@ reset-callbacks
|
|||
|
||||
"NSObject" "FactorCallback" {
|
||||
{ "perform:" "void" { "id" "SEL" "id" }
|
||||
[ 2drop callbacks get hash call ]
|
||||
[ 2drop callbacks get hash ui-try ]
|
||||
}
|
||||
|
||||
{ "dealloc" "void" { "id" "SEL" }
|
||||
|
|
|
|||
|
|
@ -1,124 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets-editors
|
||||
USING: arrays freetype gadgets gadgets-labels gadgets-scrolling
|
||||
gadgets-theme generic kernel math namespaces sequences strings
|
||||
styles threads ;
|
||||
|
||||
! A caret
|
||||
TUPLE: caret ;
|
||||
|
||||
C: caret ( -- caret )
|
||||
dup delegate>gadget
|
||||
dup caret-theme
|
||||
f over set-gadget-visible? ;
|
||||
|
||||
USE: line-editor
|
||||
|
||||
! An editor gadget wraps a line editor object and passes
|
||||
! gestures to the line editor.
|
||||
|
||||
TUPLE: editor line caret font color ;
|
||||
|
||||
: with-editor ( editor quot -- )
|
||||
#! Execute a quotation in the line editor scope, then
|
||||
#! update the display.
|
||||
swap [ editor-line swap bind ] keep
|
||||
dup relayout editor-caret scroll>gadget ; inline
|
||||
|
||||
: editor-text ( editor -- text )
|
||||
editor-line [ line-text get ] bind ;
|
||||
|
||||
: set-editor-text ( text editor -- )
|
||||
[ set-line-text ] with-editor ;
|
||||
|
||||
: commit-editor-text ( editor -- line )
|
||||
#! Add current line to the history, and clear the editor.
|
||||
[ commit-history line-text get line-clear ] with-editor ;
|
||||
|
||||
: run-char-widths ( font str -- wlist )
|
||||
#! List of x co-ordinates of each character.
|
||||
>array [ char-width ] map-with
|
||||
dup 0 [ + ] accumulate swap 2 v/n v+ ;
|
||||
|
||||
: x>offset ( x font str -- offset )
|
||||
dup >r run-char-widths [ <= ] find-with drop dup -1 =
|
||||
[ drop r> length ] [ r> drop ] if ;
|
||||
|
||||
: set-caret-x ( x editor -- )
|
||||
#! Move the caret to a clicked location.
|
||||
dup [
|
||||
label-font lookup-font line-text get
|
||||
x>offset set-caret-pos
|
||||
] with-editor ;
|
||||
|
||||
: click-editor ( editor -- )
|
||||
dup hand-click-rel first over set-caret-x request-focus ;
|
||||
|
||||
editor H{
|
||||
{ T{ button-down } [ click-editor ] }
|
||||
{ T{ gain-focus } [ editor-caret show-gadget ] }
|
||||
{ T{ lose-focus } [ editor-caret hide-gadget ] }
|
||||
{ T{ key-down f f "BACKSPACE" } [ [ T{ char-elt } delete-prev-elt ] with-editor ] }
|
||||
{ T{ key-down f f "DELETE" } [ [ T{ char-elt } delete-next-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "BACKSPACE" } [ [ T{ word-elt } delete-prev-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "DELETE" } [ [ T{ word-elt } delete-next-elt ] with-editor ] }
|
||||
{ T{ key-down f { A+ } "BACKSPACE" } [ [ T{ document-elt } delete-prev-elt ] with-editor ] }
|
||||
{ T{ key-down f { A+ } "DELETE" } [ [ T{ document-elt } delete-next-elt ] with-editor ] }
|
||||
{ T{ key-down f f "LEFT" } [ [ T{ char-elt } prev-elt ] with-editor ] }
|
||||
{ T{ key-down f f "RIGHT" } [ [ T{ char-elt } next-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "LEFT" } [ [ T{ word-elt } prev-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "RIGHT" } [ [ T{ word-elt } next-elt ] with-editor ] }
|
||||
{ T{ key-down f f "HOME" } [ [ T{ document-elt } prev-elt ] with-editor ] }
|
||||
{ T{ key-down f f "END" } [ [ T{ document-elt } next-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "k" } [ [ line-clear ] with-editor ] }
|
||||
{ T{ button-up f 2 } [ dup click-editor selection get paste-clipboard ] }
|
||||
{ T{ paste-action } [ clipboard get paste-clipboard ] }
|
||||
} set-gestures
|
||||
|
||||
: add-editor-caret 2dup set-editor-caret add-gadget ;
|
||||
|
||||
C: editor ( text -- )
|
||||
dup delegate>gadget
|
||||
dup editor-theme
|
||||
<line-editor> over set-editor-line
|
||||
<caret> over add-editor-caret
|
||||
[ set-editor-text ] keep ;
|
||||
|
||||
: offset>x ( gadget offset str -- x )
|
||||
head-slice >r label-font lookup-font r> string-width ;
|
||||
|
||||
: caret-loc ( editor -- x y )
|
||||
dup editor-line [ caret-pos line-text get ] bind offset>x
|
||||
0 2array ;
|
||||
|
||||
: caret-dim ( editor -- w h )
|
||||
rect-dim { 0 1 } v* { 1 0 } v+ ;
|
||||
|
||||
M: editor user-input* ( str editor -- ? )
|
||||
[ insert-string ] with-editor f ;
|
||||
|
||||
M: editor pref-dim* ( editor -- dim )
|
||||
label-size { 1 0 } v+ ;
|
||||
|
||||
M: editor layout* ( editor -- )
|
||||
dup editor-caret over caret-dim swap set-layout-dim
|
||||
dup editor-caret swap caret-loc swap set-rect-loc ;
|
||||
|
||||
M: editor label-text editor-text ;
|
||||
|
||||
M: editor label-color editor-color ;
|
||||
|
||||
M: editor label-font editor-font ;
|
||||
|
||||
M: editor set-label-text set-editor-text ;
|
||||
|
||||
M: editor set-label-color set-editor-color ;
|
||||
|
||||
M: editor set-label-font set-editor-font ;
|
||||
|
||||
M: editor draw-gadget* ( editor -- ) draw-label ;
|
||||
|
||||
: set-possibilities ( possibilities editor -- )
|
||||
#! Set completion possibilities.
|
||||
[ possibilities set ] with-editor ;
|
||||
|
|
@ -1,152 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: line-editor
|
||||
USING: kernel math namespaces sequences strings vectors words ;
|
||||
|
||||
SYMBOL: history
|
||||
SYMBOL: history-index
|
||||
|
||||
SYMBOL: line-text
|
||||
SYMBOL: caret
|
||||
|
||||
! Completion
|
||||
SYMBOL: possibilities
|
||||
|
||||
: history-length ( -- n )
|
||||
#! Call this in the line editor scope.
|
||||
history get length ;
|
||||
|
||||
: reset-history ( -- )
|
||||
#! Call this in the line editor scope. After user input,
|
||||
#! resets the history index.
|
||||
history-length history-index set ;
|
||||
|
||||
! A point is a mutable object holding an index in the line
|
||||
! editor. Changing text in the points registered with the
|
||||
! line editor will move the point if it is after the changed
|
||||
! text.
|
||||
TUPLE: point index ;
|
||||
|
||||
: (point-update) ( len from to index -- index )
|
||||
pick over > [
|
||||
>r 3drop r>
|
||||
] [
|
||||
3dup -rot between? [ 2drop ] [ >r - + r> ] if +
|
||||
] if ;
|
||||
|
||||
: point-update ( len from to point -- )
|
||||
#! Call this in the line editor scope.
|
||||
[ point-index (point-update) ] keep set-point-index ;
|
||||
|
||||
: line-replace ( str from to -- )
|
||||
#! Call this in the line editor scope.
|
||||
reset-history
|
||||
pick length pick pick caret get point-update
|
||||
line-text [ replace-slice ] change ;
|
||||
|
||||
: line-remove ( from to -- )
|
||||
#! Call this in the line editor scope.
|
||||
"" -rot line-replace ;
|
||||
|
||||
: line-length line-text get length ;
|
||||
|
||||
: set-line-text ( text -- )
|
||||
#! Call this in the line editor scope.
|
||||
0 line-length line-replace ;
|
||||
|
||||
: line-clear ( -- )
|
||||
#! Call this in the line editor scope.
|
||||
"" set-line-text ;
|
||||
|
||||
! An element is a unit of text; character, word, etc.
|
||||
GENERIC: next-elt* ( i str element -- i )
|
||||
GENERIC: prev-elt* ( i str element -- i )
|
||||
|
||||
TUPLE: char-elt ;
|
||||
|
||||
M: char-elt next-elt* 2drop 1+ ;
|
||||
M: char-elt prev-elt* 2drop 1- ;
|
||||
|
||||
TUPLE: word-elt ;
|
||||
|
||||
M: word-elt next-elt* ( i str element -- i )
|
||||
drop dup length >r [ blank? ] find* drop dup -1 =
|
||||
[ drop r> ] [ r> drop 1+ ] if ;
|
||||
|
||||
M: word-elt prev-elt* ( i str element -- i )
|
||||
drop >r 1- r> [ blank? ] find-last* drop 1+ ;
|
||||
|
||||
TUPLE: document-elt ;
|
||||
|
||||
M: document-elt next-elt* rot 2drop length ;
|
||||
M: document-elt prev-elt* 3drop 0 ;
|
||||
|
||||
: caret-pos caret get point-index ;
|
||||
|
||||
: set-caret-pos caret get set-point-index ;
|
||||
|
||||
: next-elt@ ( element -- from to )
|
||||
>r caret-pos dup line-text get r> next-elt* line-length min ;
|
||||
|
||||
: next-elt ( element -- )
|
||||
next-elt@ set-caret-pos drop ;
|
||||
|
||||
: prev-elt@ ( element -- from to )
|
||||
>r caret-pos dup line-text get r> prev-elt* 0 max swap ;
|
||||
|
||||
: prev-elt ( element -- )
|
||||
prev-elt@ drop set-caret-pos ;
|
||||
|
||||
: delete-next-elt ( element -- )
|
||||
next-elt@ line-remove ;
|
||||
|
||||
: delete-prev-elt ( element -- )
|
||||
prev-elt@ line-remove ;
|
||||
|
||||
: insert-string ( str -- )
|
||||
#! Call this in the line editor scope.
|
||||
caret-pos dup line-replace ;
|
||||
|
||||
: commit-history ( -- )
|
||||
#! Call this in the line editor scope. Adds the currently
|
||||
#! entered text to the history.
|
||||
line-text get dup empty?
|
||||
[ drop ] [ history get push reset-history ] if ;
|
||||
|
||||
: <line-editor> ( -- editor )
|
||||
[
|
||||
"" line-text set
|
||||
0 <point> caret set
|
||||
V{ } clone history set
|
||||
0 history-index set
|
||||
possibilities off
|
||||
] make-hash ;
|
||||
|
||||
: goto-history ( n -- )
|
||||
#! Call this in the line editor scope.
|
||||
dup history get nth set-line-text history-index set ;
|
||||
|
||||
: history-prev ( -- )
|
||||
#! Call this in the line editor scope.
|
||||
history-index get dup zero? [
|
||||
drop
|
||||
] [
|
||||
dup history-length = [ commit-history ] when
|
||||
1- goto-history
|
||||
] if ;
|
||||
|
||||
: history-next ( -- )
|
||||
#! Call this in the line editor scope.
|
||||
history-index get dup 1+ history-length >=
|
||||
[ drop ] [ 1+ goto-history ] if ;
|
||||
|
||||
: line-completions ( -- seq )
|
||||
T{ word-elt } prev-elt@ 2dup = [
|
||||
2drop f
|
||||
] [
|
||||
line-text get subseq possibilities get completions
|
||||
[ word-name ] map
|
||||
] if ;
|
||||
|
||||
: complete ( completion -- )
|
||||
T{ word-elt } prev-elt@ line-replace ;
|
||||
|
|
@ -2,56 +2,22 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-panes
|
||||
USING: arrays gadgets gadgets-buttons gadgets-controls
|
||||
gadgets-editors gadgets-frames gadgets-grids gadgets-labels
|
||||
gadgets-scrolling gadgets-theme generic hashtables io kernel
|
||||
line-editor math namespaces prettyprint sequences strings styles
|
||||
threads ;
|
||||
gadgets-frames gadgets-grids gadgets-labels gadgets-scrolling
|
||||
gadgets-theme generic hashtables io kernel math namespaces
|
||||
sequences strings ;
|
||||
|
||||
TUPLE: pane output active current input prototype continuation ;
|
||||
TUPLE: pane output active current prototype ;
|
||||
|
||||
: add-output 2dup set-pane-output add-gadget ;
|
||||
|
||||
: <active-line> ( current input -- line )
|
||||
2array [ ] subset make-shelf ;
|
||||
|
||||
: init-line ( pane -- )
|
||||
dup pane-prototype clone swap set-pane-current ;
|
||||
|
||||
: prepare-line ( pane -- )
|
||||
dup init-line dup pane-active unparent
|
||||
[ dup pane-current swap pane-input <active-line> ] keep
|
||||
[ pane-current 1array make-shelf ] keep
|
||||
2dup set-pane-active add-gadget ;
|
||||
|
||||
: pop-continuation ( pane -- quot )
|
||||
dup pane-continuation f rot set-pane-continuation ;
|
||||
|
||||
: pane-eval ( string pane -- )
|
||||
pop-continuation dup [
|
||||
[ continue-with ] in-thread
|
||||
] when 2drop ;
|
||||
|
||||
SYMBOL: structured-input
|
||||
|
||||
: pane-call ( quot pane -- )
|
||||
dup [ "Command: " write over short. ] with-stream*
|
||||
>r structured-input set-global
|
||||
"\"structured-input\" \"gadgets-panes\" lookup get-global call"
|
||||
r> pane-eval ;
|
||||
|
||||
: replace-input ( string pane -- ) pane-input set-editor-text ;
|
||||
|
||||
: print-input ( string pane -- )
|
||||
[
|
||||
dup [
|
||||
<input> presented set
|
||||
bold font-style set
|
||||
] make-hash format terpri
|
||||
] with-stream* ;
|
||||
|
||||
: pane-commit ( pane -- )
|
||||
dup pane-input commit-editor-text
|
||||
swap 2dup print-input pane-eval ;
|
||||
|
||||
: pane-clear ( pane -- )
|
||||
dup pane-output clear-incremental pane-current clear-gadget ;
|
||||
|
||||
|
|
@ -61,20 +27,6 @@ C: pane ( -- pane )
|
|||
<pile> <incremental> over add-output
|
||||
dup prepare-line ;
|
||||
|
||||
pane H{
|
||||
{ T{ button-down } [ pane-input click-editor ] }
|
||||
{ T{ key-down f f "RETURN" } [ pane-commit ] }
|
||||
{ T{ key-down f f "UP" } [ pane-input [ history-prev ] with-editor ] }
|
||||
{ T{ key-down f f "DOWN" } [ pane-input [ history-next ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "l" } [ pane-clear ] }
|
||||
} set-gestures
|
||||
|
||||
: <input-pane> ( -- pane )
|
||||
<pane> "" <editor> over set-pane-input ;
|
||||
|
||||
M: pane focusable-child* ( pane -- editor )
|
||||
pane-input [ t ] unless* ;
|
||||
|
||||
: prepare-print ( current -- gadget )
|
||||
#! Optimization: if line has 1 child, add the child.
|
||||
dup gadget-children {
|
||||
|
|
@ -105,12 +57,10 @@ M: pane focusable-child* ( pane -- editor )
|
|||
! Panes are streams.
|
||||
M: pane stream-flush ( pane -- ) drop ;
|
||||
|
||||
M: pane stream-readln ( pane -- line )
|
||||
[ over set-pane-continuation stop ] callcc1 nip ;
|
||||
|
||||
: scroll-pane ( pane -- )
|
||||
#! Only input panes scroll.
|
||||
dup pane-input [ dup pane-active scroll>gadget ] when drop ;
|
||||
drop ;
|
||||
! dup pane-input [ dup pane-active scroll>gadget ] when drop ;
|
||||
|
||||
M: pane stream-terpri ( pane -- )
|
||||
dup pane-current prepare-print
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ sequences words ;
|
|||
|
||||
: (gestures) ( gadget -- )
|
||||
[
|
||||
dup "gestures" word-prop [ , ] when* delegate (gestures)
|
||||
dup class "gestures" word-prop [ , ] when*
|
||||
delegate (gestures)
|
||||
] when* ;
|
||||
|
||||
: gestures ( gadget -- seq ) [ (gestures) ] { } make ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ test ;
|
|||
TUPLE: document locs ;
|
||||
|
||||
C: document ( -- document )
|
||||
{ "" } <history> over set-delegate
|
||||
V{ "" } clone <history> over set-delegate
|
||||
V{ } clone over set-document-locs ;
|
||||
|
||||
: add-loc document-locs push ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: gadgets-text
|
||||
USING: arrays errors freetype gadgets gadgets-borders
|
||||
gadgets-buttons gadgets-frames gadgets-labels gadgets-scrolling
|
||||
gadgets-theme io kernel math models namespaces opengl sequences
|
||||
io kernel math models namespaces opengl sequences
|
||||
strings styles ;
|
||||
|
||||
TUPLE: editor
|
||||
|
|
|
|||
|
|
@ -13,12 +13,13 @@ C: field ( model -- field )
|
|||
|
||||
: field-next editor-document go-forward ;
|
||||
|
||||
: field-commit ( field -- )
|
||||
dup field-model [ >r editor-text r> set-model ] when*
|
||||
: field-commit ( field -- string )
|
||||
[ editor-text ] keep
|
||||
dup field-model [ dupd set-model ] when*
|
||||
editor-document dup add-history clear-doc ;
|
||||
|
||||
field H{
|
||||
{ T{ key-down f { C+ } "p" } [ field-prev ] }
|
||||
{ T{ key-down f { C+ } "n" } [ field-next ] }
|
||||
{ T{ key-down f f "ENTER" } [ field-commit ] }
|
||||
{ T{ key-down f f "RETURN" } [ field-commit drop ] }
|
||||
} set-gestures
|
||||
|
|
|
|||
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-text
|
||||
USING: gadgets gadgets-panes io kernel namespaces prettyprint
|
||||
styles threads ;
|
||||
|
||||
TUPLE: interactor output continuation ;
|
||||
|
||||
C: interactor ( output -- gadget )
|
||||
[ set-interactor-output ] keep
|
||||
f <field> over set-gadget-delegate ;
|
||||
|
||||
: interactor-eval ( string gadget -- )
|
||||
interactor-continuation dup
|
||||
[ [ continue-with ] in-thread ] [ 2drop ] if ;
|
||||
|
||||
SYMBOL: structured-input
|
||||
|
||||
: interactor-call ( quot gadget -- )
|
||||
dup interactor-output [
|
||||
"Command: " write over short.
|
||||
] with-stream*
|
||||
>r structured-input set-global
|
||||
"\"structured-input\" \"gadgets-text\" lookup get-global call"
|
||||
r> interactor-eval ;
|
||||
|
||||
: print-input ( string interactor -- )
|
||||
interactor-output [
|
||||
dup [
|
||||
<input> presented set
|
||||
bold font-style set
|
||||
] make-hash format terpri
|
||||
] with-stream* ;
|
||||
|
||||
: interactor-commit ( gadget -- )
|
||||
dup field-commit
|
||||
swap 2dup print-input interactor-eval ;
|
||||
|
||||
interactor H{
|
||||
{ T{ key-down f f "RETURN" } [ interactor-commit ] }
|
||||
{ T{ key-down f { C+ } "l" } [ interactor-output pane-clear ] }
|
||||
} set-gestures
|
||||
|
||||
M: interactor stream-readln ( pane -- line )
|
||||
[ over set-interactor-continuation stop ] callcc1 nip ;
|
||||
|
|
@ -1,21 +1,25 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-listener
|
||||
USING: arrays gadgets gadgets-editors gadgets-frames
|
||||
gadgets-labels gadgets-panes gadgets-presentations
|
||||
gadgets-scrolling gadgets-theme gadgets-tiles gadgets-tracks
|
||||
generic hashtables inspector io jedit kernel listener math
|
||||
models namespaces parser prettyprint sequences shells styles
|
||||
threads words ;
|
||||
USING: arrays gadgets gadgets-frames gadgets-labels
|
||||
gadgets-panes gadgets-presentations gadgets-scrolling
|
||||
gadgets-text gadgets-theme gadgets-tiles gadgets-tracks generic
|
||||
hashtables inspector io jedit kernel listener math models
|
||||
namespaces parser prettyprint sequences shells styles threads
|
||||
words ;
|
||||
|
||||
TUPLE: listener-gadget pane stack ;
|
||||
TUPLE: listener-gadget input output stack ;
|
||||
|
||||
: ui-listener-hook ( listener -- )
|
||||
>r datastack-hook get call r>
|
||||
listener-gadget-stack set-model ;
|
||||
|
||||
: listener-stream ( listener -- stream )
|
||||
dup listener-gadget-input swap listener-gadget-output
|
||||
<duplex-stream> ;
|
||||
|
||||
: listener-thread ( listener -- )
|
||||
dup listener-gadget-pane [
|
||||
dup listener-stream [
|
||||
[ ui-listener-hook ] curry listener-hook set tty
|
||||
] with-stream* ;
|
||||
|
||||
|
|
@ -23,6 +27,9 @@ TUPLE: listener-gadget pane stack ;
|
|||
[ >r clear r> init-namespaces listener-thread ] in-thread
|
||||
drop ;
|
||||
|
||||
: <listener-input> ( -- gadget )
|
||||
gadget get listener-gadget-output <interactor> ;
|
||||
|
||||
: <pane-tile> ( model quot title -- gadget )
|
||||
>r <pane-control> <scroller> r> f <tile> ;
|
||||
|
||||
|
|
@ -34,7 +41,8 @@ TUPLE: listener-gadget pane stack ;
|
|||
|
||||
C: listener-gadget ( -- gadget )
|
||||
f <model> over set-listener-gadget-stack {
|
||||
{ [ <input-pane> ] set-listener-gadget-pane [ <scroller> ] 5/6 }
|
||||
{ [ <pane> ] set-listener-gadget-output [ <scroller> ] 4/6 }
|
||||
{ [ <listener-input> ] set-listener-gadget-input [ <scroller> ] 1/6 }
|
||||
{ [ <stack-display> ] f f 1/6 }
|
||||
} { 0 1 } make-track* dup start-listener ;
|
||||
|
||||
|
|
@ -42,15 +50,15 @@ M: listener-gadget pref-dim*
|
|||
delegate pref-dim* { 600 600 } vmax ;
|
||||
|
||||
M: listener-gadget focusable-child* ( listener -- gadget )
|
||||
listener-gadget-pane ;
|
||||
listener-gadget-input ;
|
||||
|
||||
M: listener-gadget gadget-title drop "Listener" <model> ;
|
||||
|
||||
: listener-window ( -- ) <listener-gadget> open-window ;
|
||||
|
||||
: call-listener ( quot/string listener -- )
|
||||
listener-gadget-pane over quotation?
|
||||
[ pane-call ] [ replace-input ] if ;
|
||||
listener-gadget-input over quotation?
|
||||
[ interactor-call ] [ set-editor-text ] if ;
|
||||
|
||||
: listener-tool
|
||||
[ listener-gadget? ]
|
||||
|
|
|
|||
|
|
@ -1,27 +1,20 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-search
|
||||
USING: gadgets gadgets-editors gadgets-frames gadgets-labels
|
||||
gadgets-panes gadgets-scrolling gadgets-theme generic help
|
||||
inspector kernel sequences words ;
|
||||
USING: gadgets gadgets-frames gadgets-labels gadgets-panes
|
||||
gadgets-scrolling gadgets-text gadgets-theme generic help
|
||||
inspector kernel models sequences words ;
|
||||
|
||||
TUPLE: search-gadget pane input quot ;
|
||||
TUPLE: search-gadget input ;
|
||||
|
||||
: do-search ( apropos -- )
|
||||
dup search-gadget-input commit-editor-text dup empty? [
|
||||
2drop
|
||||
] [
|
||||
over search-gadget-pane
|
||||
rot search-gadget-quot with-pane
|
||||
] if ;
|
||||
|
||||
search-gadget H{ { T{ key-down f f "RETURN" } [ do-search ] } }
|
||||
set-gestures
|
||||
: <search-pane> ( model quot -- )
|
||||
[ over empty? [ 2drop ] [ call ] if ] curry
|
||||
<pane-control> ;
|
||||
|
||||
C: search-gadget ( quot -- )
|
||||
[ set-search-gadget-quot ] keep {
|
||||
{ [ <pane> ] set-search-gadget-pane [ <scroller> ] @center }
|
||||
{ [ "" <editor> ] set-search-gadget-input f @top }
|
||||
>r f <model> dup r> {
|
||||
{ [ <field> ] set-search-gadget-input f @top }
|
||||
{ [ swap <search-pane> <scroller> ] f f @center }
|
||||
} make-frame* ;
|
||||
|
||||
M: search-gadget focusable-child* search-gadget-input ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue