fully clean up gadgets.editors
Doug Coleman
parent
41e6c8f3be
commit
a273cbb68e
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays documents documents.elements kernel math
|
||||
math.ranges models models.arrow namespaces locals fry make opengl
|
||||
opengl.gl sequences strings math.vectors math.functions sorting colors
|
||||
colors.constants combinators assocs math.order calendar alarms
|
||||
continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid
|
||||
ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment
|
||||
math.rectangles splitting unicode.categories grouping ;
|
||||
USING: accessors alarms arrays assocs calendar colors.constants
|
||||
combinators combinators.short-circuit documents
|
||||
documents.elements fry grouping kernel locals make math
|
||||
math.functions math.order math.ranges math.rectangles
|
||||
math.vectors models models.arrow namespaces opengl sequences
|
||||
sorting splitting ui.baseline-alignment ui.clipboards
|
||||
ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.line-support ui.gadgets.menus ui.gadgets.scrollers
|
||||
ui.gestures ui.pens.solid ui.render ui.text unicode.categories ;
|
||||
EXCLUDE: fonts => selection ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
|
|
@ -37,14 +37,14 @@ focused? blink blink-alarm ;
|
|||
editor new-editor ;
|
||||
|
||||
: activate-editor-model ( editor model -- )
|
||||
2dup add-connection
|
||||
dup activate-model
|
||||
swap model>> add-loc ;
|
||||
[ add-connection ]
|
||||
[ nip activate-model ]
|
||||
[ swap model>> add-loc ] 2tri ;
|
||||
|
||||
: deactivate-editor-model ( editor model -- )
|
||||
2dup remove-connection
|
||||
dup deactivate-model
|
||||
swap model>> remove-loc ;
|
||||
[ remove-connection ]
|
||||
[ nip deactivate-model ]
|
||||
[ swap model>> remove-loc ] 2tri ;
|
||||
|
||||
: blink-caret ( editor -- )
|
||||
[ not ] change-blink relayout-1 ;
|
||||
|
|
@ -71,15 +71,13 @@ SYMBOL: blink-interval
|
|||
] [ drop ] if ;
|
||||
|
||||
M: editor graft*
|
||||
dup
|
||||
dup caret>> activate-editor-model
|
||||
dup mark>> activate-editor-model ;
|
||||
[ dup caret>> activate-editor-model ]
|
||||
[ dup mark>> activate-editor-model ] bi ;
|
||||
|
||||
M: editor ungraft*
|
||||
dup
|
||||
dup stop-blinking
|
||||
dup caret>> deactivate-editor-model
|
||||
dup mark>> deactivate-editor-model ;
|
||||
[ stop-blinking ]
|
||||
[ dup caret>> deactivate-editor-model ]
|
||||
[ dup mark>> deactivate-editor-model ] tri ;
|
||||
|
||||
: editor-caret ( editor -- loc ) caret>> value>> ;
|
||||
|
||||
|
|
@ -114,7 +112,7 @@ M: editor ungraft*
|
|||
} cond ;
|
||||
|
||||
: clicked-loc ( editor -- loc )
|
||||
[ hand-rel ] keep point>loc ;
|
||||
[ hand-rel ] [ point>loc ] bi ;
|
||||
|
||||
: click-loc ( editor model -- )
|
||||
[ clicked-loc ] dip set-model ;
|
||||
|
|
@ -132,7 +130,7 @@ M: editor ungraft*
|
|||
[ loc>x ] [ [ first ] dip line>y ceiling ] 2bi 2array ;
|
||||
|
||||
: caret-loc ( editor -- loc )
|
||||
[ editor-caret ] keep loc>point ;
|
||||
[ editor-caret ] [ loc>point ] bi ;
|
||||
|
||||
: caret-dim ( editor -- dim )
|
||||
[ 0 ] dip line-height 2array ;
|
||||
|
|
@ -141,11 +139,11 @@ M: editor ungraft*
|
|||
dup graft-state>> second [
|
||||
[
|
||||
[ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
|
||||
] keep scroll>rect
|
||||
] [ scroll>rect ] bi
|
||||
] [ drop ] if ;
|
||||
|
||||
: draw-caret? ( editor -- ? )
|
||||
[ focused?>> ] [ blink>> ] bi and ;
|
||||
{ [ focused?>> ] [ blink>> ] } 1&& ;
|
||||
|
||||
: draw-caret ( editor -- )
|
||||
dup draw-caret? [
|
||||
|
|
@ -165,8 +163,9 @@ TUPLE: selected-line start end first? last? ;
|
|||
|
||||
: compute-selection ( editor -- assoc )
|
||||
dup gadget-selection? [
|
||||
[ selection-start/end [ [ first ] bi@ [a,b] ] 2keep ] keep model>>
|
||||
'[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc
|
||||
[ selection-start/end [ [ first ] bi@ [a,b] ] [ ] 2bi ]
|
||||
[ model>> ] bi
|
||||
'[ [ _ _ ] [ _ start/end-on-line ] bi 2array ] H{ } map>assoc
|
||||
] [ drop f ] if ;
|
||||
|
||||
:: draw-selection ( line pair editor -- )
|
||||
|
|
@ -185,8 +184,8 @@ TUPLE: selected-line start end first? last? ;
|
|||
] [
|
||||
[ draw-selection ]
|
||||
[
|
||||
[ [ first2 ] [ selection-color>> ] bi* <selection> ] keep
|
||||
draw-unselected-line
|
||||
[ [ first2 ] [ selection-color>> ] bi* <selection> ]
|
||||
[ draw-unselected-line ] bi
|
||||
] 3bi
|
||||
] if ;
|
||||
|
||||
|
|
@ -208,19 +207,18 @@ M: editor baseline font>> font-metrics ascent>> ;
|
|||
M: editor cap-height font>> font-metrics cap-height>> ;
|
||||
|
||||
: contents-changed ( model editor -- )
|
||||
swap
|
||||
over caret>> [ over validate-loc ] (change-model)
|
||||
over mark>> [ over validate-loc ] (change-model)
|
||||
drop relayout ;
|
||||
[ [ nip caret>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
|
||||
[ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
|
||||
[ nip relayout ] 2tri ;
|
||||
|
||||
: caret/mark-changed ( model editor -- )
|
||||
nip [ restart-blinking ] [ scroll>caret ] bi ;
|
||||
: caret/mark-changed ( editor -- )
|
||||
[ restart-blinking ] [ scroll>caret ] bi ;
|
||||
|
||||
M: editor model-changed
|
||||
{
|
||||
{ [ 2dup model>> eq? ] [ contents-changed ] }
|
||||
{ [ 2dup caret>> eq? ] [ caret/mark-changed ] }
|
||||
{ [ 2dup mark>> eq? ] [ caret/mark-changed ] }
|
||||
{ [ 2dup caret>> eq? ] [ nip caret/mark-changed ] }
|
||||
{ [ 2dup mark>> eq? ] [ nip caret/mark-changed ] }
|
||||
} cond ;
|
||||
|
||||
M: editor gadget-selection?
|
||||
|
|
@ -244,9 +242,9 @@ M: editor user-input*
|
|||
M: editor gadget-text* editor-string % ;
|
||||
|
||||
: extend-selection ( editor -- )
|
||||
dup request-focus
|
||||
dup restart-blinking
|
||||
dup caret>> click-loc ;
|
||||
[ request-focus ]
|
||||
[ restart-blinking ]
|
||||
[ dup caret>> click-loc ] tri ;
|
||||
|
||||
: mouse-elt ( -- element )
|
||||
hand-click# get {
|
||||
|
|
@ -259,7 +257,7 @@ M: editor gadget-text* editor-string % ;
|
|||
|
||||
: drag-selection-caret ( loc editor element -- loc )
|
||||
[
|
||||
[ drag-direction? ] 2keep model>>
|
||||
[ drag-direction? ] [ model>> ] 2bi
|
||||
] dip prev/next-elt ? ;
|
||||
|
||||
: drag-selection-mark ( loc editor element -- loc )
|
||||
|
|
@ -275,9 +273,9 @@ M: editor gadget-text* editor-string % ;
|
|||
[ drag-selection-mark ] 3bi ;
|
||||
|
||||
: drag-selection ( editor -- )
|
||||
dup drag-caret&mark
|
||||
pick mark>> set-model
|
||||
swap caret>> set-model ;
|
||||
[ drag-caret&mark ]
|
||||
[ mark>> set-model ]
|
||||
[ caret>> set-model ] tri ;
|
||||
|
||||
: editor-cut ( editor clipboard -- )
|
||||
[ gadget-copy ] [ drop remove-selection ] 2bi ;
|
||||
|
|
@ -343,11 +341,9 @@ M: editor gadget-text* editor-string % ;
|
|||
: delete-to-end-of-line ( editor -- )
|
||||
one-line-elt editor-backspace ;
|
||||
|
||||
: com-undo ( editor -- )
|
||||
model>> undo ;
|
||||
: com-undo ( editor -- ) model>> undo ;
|
||||
|
||||
: com-redo ( editor -- )
|
||||
model>> redo ;
|
||||
: com-redo ( editor -- ) model>> redo ;
|
||||
|
||||
editor "editing" f {
|
||||
{ undo-action com-undo }
|
||||
|
|
@ -515,7 +511,7 @@ PRIVATE>
|
|||
"\n" swap user-input* drop ;
|
||||
|
||||
: change-selection ( editor quot -- )
|
||||
'[ gadget-selection @ ] keep user-input* drop ; inline
|
||||
'[ gadget-selection @ ] [ user-input* drop ] bi ; inline
|
||||
|
||||
: join-lines ( string -- string' )
|
||||
"\n" split
|
||||
|
|
@ -526,7 +522,7 @@ PRIVATE>
|
|||
|
||||
: this-line-and-next ( document line -- start end )
|
||||
[ nip 0 swap 2array ]
|
||||
[ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ]
|
||||
[ 1 + [ nip ] [ swap doc-line length ] 2bi 2array ]
|
||||
2bi ;
|
||||
|
||||
: last-line? ( document line -- ? )
|
||||
|
|
@ -589,15 +585,16 @@ TUPLE: field < border editor min-cols max-cols ;
|
|||
M: field font>> editor>> font>> ;
|
||||
|
||||
M: field pref-dim*
|
||||
dup
|
||||
[ editor>> pref-dim ] keep
|
||||
[ line-gadget-width ] [ drop second ] 2bi 2array
|
||||
border-pref-dim ;
|
||||
[ ]
|
||||
[ editor>> pref-dim ]
|
||||
[ [ line-gadget-width ] [ drop second ] 2bi 2array ]
|
||||
tri border-pref-dim ;
|
||||
|
||||
TUPLE: model-field < field field-model ;
|
||||
|
||||
: <model-field> ( model -- gadget )
|
||||
model-field new-field swap >>field-model ;
|
||||
model-field new-field
|
||||
swap >>field-model ;
|
||||
|
||||
M: model-field graft*
|
||||
[ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
|
||||
|
|
@ -613,7 +610,8 @@ M: model-field model-changed
|
|||
TUPLE: action-field < field quot ;
|
||||
|
||||
: <action-field> ( quot -- gadget )
|
||||
action-field new-field swap >>quot ;
|
||||
action-field new-field
|
||||
swap >>quot ;
|
||||
|
||||
: invoke-action-field ( field -- )
|
||||
[ editor>> editor-string ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue