Use singleton classes instead of tuples for document elements
parent
c7ea91acda
commit
1f11b0d78b
|
@ -90,17 +90,17 @@ USING: documents namespaces tools.test make arrays kernel fry ;
|
|||
|
||||
<document> "doc" set
|
||||
"Hello world" "doc" get set-doc-string
|
||||
[ { 0 0 } ] [ { 0 0 } "doc" get T{ one-word-elt } prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } "doc" get T{ one-word-elt } prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } "doc" get T{ one-word-elt } prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 2 } "doc" get T{ one-word-elt } next-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 5 } "doc" get T{ one-word-elt } next-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
|
||||
|
||||
<document> "doc" set
|
||||
"Hello\nworld, how are\nyou?" "doc" get set-doc-string
|
||||
|
||||
[ { 2 4 } ] [ "doc" get doc-end ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ { 0 3 } "doc" get T{ line-elt } prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 3 } "doc" get T{ line-elt } prev-elt ] unit-test
|
||||
[ { 2 4 } ] [ { 2 1 } "doc" get T{ line-elt } next-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays io kernel math models namespaces make
|
||||
sequences strings splitting combinators unicode.categories
|
||||
math.order math.ranges ;
|
||||
math.order math.ranges fry ;
|
||||
IN: documents
|
||||
|
||||
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
|
||||
|
@ -150,7 +150,7 @@ GENERIC: next-elt ( loc document elt -- newloc )
|
|||
: elt-string ( loc document elt -- string )
|
||||
[ prev/next-elt ] [ drop ] 2bi doc-range ;
|
||||
|
||||
TUPLE: char-elt ;
|
||||
SINGLETON: char-elt
|
||||
|
||||
: (prev-char) ( loc document quot -- loc )
|
||||
{
|
||||
|
@ -172,7 +172,7 @@ M: char-elt prev-elt
|
|||
M: char-elt next-elt
|
||||
drop [ drop 1 +col ] (next-char) ;
|
||||
|
||||
TUPLE: one-char-elt ;
|
||||
SINGLETON: one-char-elt
|
||||
|
||||
M: one-char-elt prev-elt 2drop ;
|
||||
|
||||
|
@ -186,7 +186,7 @@ M: one-char-elt next-elt 2drop ;
|
|||
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
|
||||
|
||||
: break-detector ( ? -- quot )
|
||||
[ [ blank? ] dip xor ] curry ; inline
|
||||
'[ blank? _ xor ] ; inline
|
||||
|
||||
: (prev-word) ( ? col str -- col )
|
||||
rot break-detector find-last-from drop ?1+ ;
|
||||
|
@ -195,7 +195,7 @@ M: one-char-elt next-elt 2drop ;
|
|||
[ rot break-detector find-from drop ] keep
|
||||
over not [ nip length ] [ drop ] if ;
|
||||
|
||||
TUPLE: one-word-elt ;
|
||||
SINGLETON: one-word-elt
|
||||
|
||||
M: one-word-elt prev-elt
|
||||
drop
|
||||
|
@ -205,7 +205,7 @@ M: one-word-elt next-elt
|
|||
drop
|
||||
[ [ f ] 2dip (next-word) ] (word-elt) ;
|
||||
|
||||
TUPLE: word-elt ;
|
||||
SINGLETON: word-elt
|
||||
|
||||
M: word-elt prev-elt
|
||||
drop
|
||||
|
@ -217,7 +217,7 @@ M: word-elt next-elt
|
|||
[ [ ((word-elt)) (next-word) ] (word-elt) ]
|
||||
(next-char) ;
|
||||
|
||||
TUPLE: one-line-elt ;
|
||||
SINGLETON: one-line-elt
|
||||
|
||||
M: one-line-elt prev-elt
|
||||
2drop first 0 2array ;
|
||||
|
@ -225,7 +225,7 @@ M: one-line-elt prev-elt
|
|||
M: one-line-elt next-elt
|
||||
drop [ first dup ] dip doc-line length 2array ;
|
||||
|
||||
TUPLE: line-elt ;
|
||||
SINGLETON: line-elt
|
||||
|
||||
M: line-elt prev-elt
|
||||
2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
|
||||
|
@ -234,7 +234,7 @@ M: line-elt next-elt
|
|||
drop over first over last-line# number=
|
||||
[ nip doc-end ] [ drop 1 +line ] if ;
|
||||
|
||||
TUPLE: doc-elt ;
|
||||
SINGLETON: doc-elt
|
||||
|
||||
M: doc-elt prev-elt 3drop { 0 0 } ;
|
||||
|
||||
|
|
|
@ -8,7 +8,7 @@ IN: ui.gadgets.editors.tests
|
|||
<editor> "editor" set
|
||||
"editor" get [
|
||||
"foo bar" "editor" get set-editor-string
|
||||
"editor" get T{ one-line-elt } select-elt
|
||||
"editor" get one-line-elt select-elt
|
||||
"editor" get gadget-selection
|
||||
] with-grafted-gadget
|
||||
] unit-test
|
||||
|
@ -17,7 +17,7 @@ IN: ui.gadgets.editors.tests
|
|||
<editor> "editor" set
|
||||
"editor" get [
|
||||
"foo bar\nbaz quux" "editor" get set-editor-string
|
||||
"editor" get T{ one-line-elt } select-elt
|
||||
"editor" get one-line-elt select-elt
|
||||
"editor" get gadget-selection
|
||||
] with-grafted-gadget
|
||||
] unit-test
|
||||
|
|
|
@ -291,9 +291,9 @@ M: editor gadget-text* editor-string % ;
|
|||
|
||||
: mouse-elt ( -- element )
|
||||
hand-click# get {
|
||||
{ 1 T{ one-char-elt } }
|
||||
{ 2 T{ one-word-elt } }
|
||||
} at T{ one-line-elt } or ;
|
||||
{ 1 one-char-elt }
|
||||
{ 2 one-word-elt }
|
||||
} at one-line-elt or ;
|
||||
|
||||
: drag-direction? ( loc editor -- ? )
|
||||
editor-mark* before? ;
|
||||
|
@ -356,34 +356,34 @@ M: editor gadget-text* editor-string % ;
|
|||
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
|
||||
editor-select ;
|
||||
|
||||
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
|
||||
: start-of-document ( editor -- ) doc-elt editor-prev ;
|
||||
|
||||
: end-of-document ( editor -- ) T{ doc-elt } editor-next ;
|
||||
: end-of-document ( editor -- ) doc-elt editor-next ;
|
||||
|
||||
: position-caret ( editor -- )
|
||||
mouse-elt dup T{ one-char-elt } =
|
||||
mouse-elt dup one-char-elt =
|
||||
[ drop dup extend-selection dup mark>> click-loc ]
|
||||
[ select-elt ] if ;
|
||||
|
||||
: insert-newline ( editor -- ) "\n" swap user-input* drop ;
|
||||
|
||||
: delete-next-character ( editor -- )
|
||||
T{ char-elt } editor-delete ;
|
||||
char-elt editor-delete ;
|
||||
|
||||
: delete-previous-character ( editor -- )
|
||||
T{ char-elt } editor-backspace ;
|
||||
char-elt editor-backspace ;
|
||||
|
||||
: delete-previous-word ( editor -- )
|
||||
T{ word-elt } editor-delete ;
|
||||
word-elt editor-delete ;
|
||||
|
||||
: delete-next-word ( editor -- )
|
||||
T{ word-elt } editor-backspace ;
|
||||
word-elt editor-backspace ;
|
||||
|
||||
: delete-to-start-of-line ( editor -- )
|
||||
T{ one-line-elt } editor-delete ;
|
||||
one-line-elt editor-delete ;
|
||||
|
||||
: delete-to-end-of-line ( editor -- )
|
||||
T{ one-line-elt } editor-backspace ;
|
||||
one-line-elt editor-backspace ;
|
||||
|
||||
editor "general" f {
|
||||
{ T{ key-down f f "DELETE" } delete-next-character }
|
||||
|
@ -415,7 +415,7 @@ editor "clipboard" f {
|
|||
dup selection-start/end drop
|
||||
over set-caret mark>caret
|
||||
] [
|
||||
T{ char-elt } editor-prev
|
||||
char-elt editor-prev
|
||||
] if ;
|
||||
|
||||
: next-character ( editor -- )
|
||||
|
@ -423,20 +423,20 @@ editor "clipboard" f {
|
|||
dup selection-start/end nip
|
||||
over set-caret mark>caret
|
||||
] [
|
||||
T{ char-elt } editor-next
|
||||
char-elt editor-next
|
||||
] if ;
|
||||
|
||||
: previous-line ( editor -- ) T{ line-elt } editor-prev ;
|
||||
: previous-line ( editor -- ) line-elt editor-prev ;
|
||||
|
||||
: next-line ( editor -- ) T{ line-elt } editor-next ;
|
||||
: next-line ( editor -- ) line-elt editor-next ;
|
||||
|
||||
: previous-word ( editor -- ) T{ word-elt } editor-prev ;
|
||||
: previous-word ( editor -- ) word-elt editor-prev ;
|
||||
|
||||
: next-word ( editor -- ) T{ word-elt } editor-next ;
|
||||
: next-word ( editor -- ) word-elt editor-next ;
|
||||
|
||||
: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
|
||||
: start-of-line ( editor -- ) one-line-elt editor-prev ;
|
||||
|
||||
: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
|
||||
: end-of-line ( editor -- ) one-line-elt editor-next ;
|
||||
|
||||
editor "caret-motion" f {
|
||||
{ T{ button-down } position-caret }
|
||||
|
@ -456,11 +456,11 @@ editor "caret-motion" f {
|
|||
#! The with-datastack is a kludge to make it infer. Stupid.
|
||||
model>> 1array [ clear-doc ] with-datastack drop ;
|
||||
|
||||
: select-all ( editor -- ) T{ doc-elt } select-elt ;
|
||||
: select-all ( editor -- ) doc-elt select-elt ;
|
||||
|
||||
: select-line ( editor -- ) T{ one-line-elt } select-elt ;
|
||||
: select-line ( editor -- ) one-line-elt select-elt ;
|
||||
|
||||
: select-word ( editor -- ) T{ one-word-elt } select-elt ;
|
||||
: select-word ( editor -- ) one-word-elt select-elt ;
|
||||
|
||||
: selected-word ( editor -- string )
|
||||
dup gadget-selection?
|
||||
|
@ -468,34 +468,34 @@ editor "caret-motion" f {
|
|||
gadget-selection ;
|
||||
|
||||
: select-previous-character ( editor -- )
|
||||
T{ char-elt } editor-select-prev ;
|
||||
char-elt editor-select-prev ;
|
||||
|
||||
: select-next-character ( editor -- )
|
||||
T{ char-elt } editor-select-next ;
|
||||
char-elt editor-select-next ;
|
||||
|
||||
: select-previous-line ( editor -- )
|
||||
T{ line-elt } editor-select-prev ;
|
||||
line-elt editor-select-prev ;
|
||||
|
||||
: select-next-line ( editor -- )
|
||||
T{ line-elt } editor-select-next ;
|
||||
line-elt editor-select-next ;
|
||||
|
||||
: select-previous-word ( editor -- )
|
||||
T{ word-elt } editor-select-prev ;
|
||||
word-elt editor-select-prev ;
|
||||
|
||||
: select-next-word ( editor -- )
|
||||
T{ word-elt } editor-select-next ;
|
||||
word-elt editor-select-next ;
|
||||
|
||||
: select-start-of-line ( editor -- )
|
||||
T{ one-line-elt } editor-select-prev ;
|
||||
one-line-elt editor-select-prev ;
|
||||
|
||||
: select-end-of-line ( editor -- )
|
||||
T{ one-line-elt } editor-select-next ;
|
||||
one-line-elt editor-select-next ;
|
||||
|
||||
: select-start-of-document ( editor -- )
|
||||
T{ doc-elt } editor-select-prev ;
|
||||
doc-elt editor-select-prev ;
|
||||
|
||||
: select-end-of-document ( editor -- )
|
||||
T{ doc-elt } editor-select-next ;
|
||||
doc-elt editor-select-next ;
|
||||
|
||||
editor "selection" f {
|
||||
{ T{ button-down f { S+ } 1 } extend-selection }
|
||||
|
|
|
@ -53,7 +53,7 @@ M: interactor ungraft*
|
|||
|
||||
: word-at-loc ( loc interactor -- word )
|
||||
over [
|
||||
[ model>> T{ one-word-elt } elt-string ] keep
|
||||
[ model>> one-word-elt elt-string ] keep
|
||||
interactor-use assoc-stack
|
||||
] [
|
||||
2drop f
|
||||
|
|
Loading…
Reference in New Issue