steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

fully clean up gadgets.editors

db4
Doug Coleman 2009-10-04 17:23:23 -05:00
parent 41e6c8f3be
commit a273cbb68e
1 changed files with 55 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

112
basis/ui/gadgets/editors/editors.factor
View File

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