Since other gadgets delegate to the editor gadget, we need to handle this at the control level
slava
parent
0cfe78aeaa
commit
208b548909
|
|
@ -10,6 +10,8 @@
|
|||
- bug after removing all lines
|
||||
- word-at-a-time commands
|
||||
- deleting words, lines
|
||||
- better listener multi-line expression handling
|
||||
- stack display: trim at 32 columns
|
||||
- shift modifier not delivered
|
||||
- x11 copy to clipboard
|
||||
|
||||
|
|
@ -43,6 +45,7 @@
|
|||
- add some handy services:
|
||||
- base conversion
|
||||
- search help for selection
|
||||
- make factor a services client
|
||||
- services do not launch if factor not running
|
||||
- grid slows down with 2000 lines
|
||||
- integrated error documentation
|
||||
|
|
|
|||
|
|
@ -3,20 +3,25 @@
|
|||
IN: gadgets-controls
|
||||
USING: gadgets kernel models ;
|
||||
|
||||
TUPLE: control model quot ;
|
||||
TUPLE: control self model quot ;
|
||||
|
||||
C: control ( model gadget quot -- gadget )
|
||||
dup dup set-control-self
|
||||
[ set-control-quot ] keep
|
||||
[ set-gadget-delegate ] keep
|
||||
[ set-control-model ] keep
|
||||
dup model-changed ;
|
||||
[ set-control-model ] keep ;
|
||||
|
||||
M: control graft*
|
||||
dup control-model add-connection ;
|
||||
dup control-self over control-model add-connection
|
||||
model-changed ;
|
||||
|
||||
M: control ungraft*
|
||||
dup control-model remove-connection ;
|
||||
dup control-self swap control-model remove-connection ;
|
||||
|
||||
M: control model-changed ( gadget -- )
|
||||
[ control-model model-value ] keep
|
||||
[ dup control-quot call ] keep relayout ;
|
||||
[ dup control-self swap control-quot call ] keep
|
||||
control-self relayout ;
|
||||
|
||||
: delegate>control ( gadget model -- )
|
||||
<gadget> [ drop ] <control> swap set-gadget-delegate ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-text
|
||||
USING: gadgets kernel models namespaces sequences ;
|
||||
USING: gadgets gadgets-controls kernel models namespaces
|
||||
sequences ;
|
||||
|
||||
: editor-mouse-down ( editor -- )
|
||||
dup request-focus
|
||||
|
|
@ -23,8 +24,8 @@ USING: gadgets kernel models namespaces sequences ;
|
|||
dupd editor-copy remove-editor-selection ;
|
||||
|
||||
: remove-at-caret ( editor quot -- | quot: caret editor -- from to )
|
||||
over >r >r dup editor-caret* swap editor-document
|
||||
r> call r> editor-document remove-doc-range ; inline
|
||||
over >r >r dup editor-caret* swap control-model
|
||||
r> call r> control-model remove-doc-range ; inline
|
||||
|
||||
: editor-delete ( editor -- )
|
||||
dup editor-selection? [
|
||||
|
|
@ -71,14 +72,14 @@ USING: gadgets kernel models namespaces sequences ;
|
|||
dup editor-select-end mark>caret ;
|
||||
|
||||
: editor-select-doc-end ( editor -- )
|
||||
dup editor-document doc-end swap editor-caret set-model ;
|
||||
dup control-model doc-end swap editor-caret set-model ;
|
||||
|
||||
: editor-doc-end ( editor -- )
|
||||
editor-select-doc-end mark>caret ;
|
||||
|
||||
: editor-select-all ( editor -- )
|
||||
{ 0 0 } over editor-caret set-model
|
||||
dup editor-document doc-end swap editor-mark set-model ;
|
||||
dup control-model doc-end swap editor-mark set-model ;
|
||||
|
||||
editor H{
|
||||
{ T{ button-down } [ editor-mouse-down ] }
|
||||
|
|
|
|||
|
|
@ -2,12 +2,11 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
strings styles ;
|
||||
gadgets-buttons gadgets-controls gadgets-frames gadgets-labels
|
||||
gadgets-scrolling gadgets-theme io kernel math models namespaces
|
||||
opengl sequences strings styles ;
|
||||
|
||||
TUPLE: editor
|
||||
document
|
||||
font color caret-color selection-color
|
||||
caret mark
|
||||
focused? ;
|
||||
|
|
@ -16,47 +15,46 @@ TUPLE: action-relayout-1 editor ;
|
|||
|
||||
M: action-relayout-1 model-changed
|
||||
#! Caret changed
|
||||
action-relayout-1-editor relayout-1 ;
|
||||
action-relayout-1-editor control-self relayout-1 ;
|
||||
|
||||
: init-editor-models ( editor -- )
|
||||
dup <action-relayout-1> over editor-caret add-connection
|
||||
dup <action-relayout-1> swap editor-mark add-connection ;
|
||||
|
||||
C: editor ( document -- editor )
|
||||
dup delegate>gadget
|
||||
<document> over set-editor-document
|
||||
dup <document> delegate>control
|
||||
{ 0 0 } <model> over set-editor-caret
|
||||
{ 0 0 } <model> over set-editor-mark
|
||||
dup init-editor-models
|
||||
dup editor-theme ;
|
||||
|
||||
: activate-editor-model ( editor model -- )
|
||||
dup activate-model swap editor-document add-loc ;
|
||||
dup activate-model swap control-model add-loc ;
|
||||
|
||||
: deactivate-editor-model ( editor model -- )
|
||||
dup deactivate-model swap editor-document remove-loc ;
|
||||
dup deactivate-model swap control-model remove-loc ;
|
||||
|
||||
M: editor graft* ( editor -- )
|
||||
dup
|
||||
dup editor-caret activate-editor-model
|
||||
dup editor-mark activate-editor-model ;
|
||||
dup dup editor-caret activate-editor-model
|
||||
dup dup editor-mark activate-editor-model
|
||||
dup control-self swap control-model add-connection ;
|
||||
|
||||
M: editor ungraft* ( editor -- )
|
||||
dup
|
||||
dup editor-caret deactivate-editor-model
|
||||
dup editor-mark deactivate-editor-model ;
|
||||
dup dup editor-caret deactivate-editor-model
|
||||
dup dup editor-mark deactivate-editor-model
|
||||
dup control-self swap control-model remove-connection ;
|
||||
|
||||
M: editor model-changed ( editor -- )
|
||||
#! Document changed
|
||||
relayout ;
|
||||
control-self relayout ;
|
||||
|
||||
: editor-caret* editor-caret model-value ;
|
||||
|
||||
: editor-mark* editor-mark model-value ;
|
||||
|
||||
: change-caret ( editor quot -- )
|
||||
over >r >r dup editor-caret* swap editor-document r> call r>
|
||||
[ editor-document validate-loc ] keep
|
||||
over >r >r dup editor-caret* swap control-model r> call r>
|
||||
[ control-model validate-loc ] keep
|
||||
editor-caret set-model ; inline
|
||||
|
||||
: mark>caret ( editor -- )
|
||||
|
|
@ -66,7 +64,7 @@ M: editor model-changed ( editor -- )
|
|||
over >r change-caret r> mark>caret ; inline
|
||||
|
||||
: editor-lines ( editor -- seq )
|
||||
editor-document model-value ;
|
||||
control-model model-value ;
|
||||
|
||||
: editor-line ( n editor -- str ) editor-lines nth ;
|
||||
|
||||
|
|
@ -132,7 +130,7 @@ M: editor model-changed ( editor -- )
|
|||
|
||||
: with-editor ( editor quot -- )
|
||||
[
|
||||
swap dup editor-document document set editor set call
|
||||
swap dup control-model document set editor set call
|
||||
] with-scope ; inline
|
||||
|
||||
: draw-lines ( editor -- )
|
||||
|
|
@ -189,17 +187,17 @@ M: editor pref-dim* ( editor -- dim )
|
|||
selection-start/end = not ;
|
||||
|
||||
: editor-selection ( editor -- str )
|
||||
[ selection-start/end ] keep editor-document doc-range ;
|
||||
[ selection-start/end ] keep control-model doc-range ;
|
||||
|
||||
: remove-editor-selection ( editor -- )
|
||||
[ selection-start/end ] keep editor-document
|
||||
[ selection-start/end ] keep control-model
|
||||
remove-doc-range ;
|
||||
|
||||
M: editor user-input* ( str editor -- ? )
|
||||
[ selection-start/end ] keep editor-document set-doc-range t ;
|
||||
[ selection-start/end ] keep control-model set-doc-range t ;
|
||||
|
||||
: editor-text ( editor -- str )
|
||||
editor-document doc-text ;
|
||||
control-model doc-text ;
|
||||
|
||||
: set-editor-text ( str editor -- )
|
||||
editor-document set-doc-text ;
|
||||
control-model set-doc-text ;
|
||||
|
|
|
|||
|
|
@ -1,26 +1,27 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-text
|
||||
USING: gadgets generic kernel models ;
|
||||
USING: gadgets gadgets-controls generic kernel models ;
|
||||
|
||||
TUPLE: field model ;
|
||||
|
||||
C: field ( model -- field )
|
||||
<editor> over set-delegate
|
||||
[ set-field-model ] keep ;
|
||||
[ set-field-model ] keep
|
||||
dup dup set-control-self ;
|
||||
|
||||
: field-prev editor-document go-back ;
|
||||
: field-prev control-model go-back ;
|
||||
|
||||
: field-next editor-document go-forward ;
|
||||
: field-next control-model go-forward ;
|
||||
|
||||
: field-commit ( field -- string )
|
||||
[ editor-text ] keep
|
||||
dup field-model [ dupd set-model ] when*
|
||||
editor-document dup add-history clear-doc ;
|
||||
control-model 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 { C+ } "k" } [ editor-document clear-doc ] }
|
||||
{ T{ key-down f { C+ } "k" } [ control-model clear-doc ] }
|
||||
{ T{ key-down f f "RETURN" } [ field-commit drop ] }
|
||||
} set-gestures
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
! 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 ;
|
||||
USING: gadgets gadgets-controls 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 ;
|
||||
f <field> over set-gadget-delegate
|
||||
dup dup set-control-self ;
|
||||
|
||||
: interactor-eval ( string gadget -- )
|
||||
interactor-continuation dup
|
||||
|
|
|
|||
Loading…
Reference in New Issue