Use singleton classes instead of tuples for document elements

db4
Slava Pestov 2008-12-24 22:38:02 -06:00
parent c7ea91acda
commit 1f11b0d78b
5 changed files with 53 additions and 53 deletions

View File

@ -90,17 +90,17 @@ USING: documents namespaces tools.test make arrays kernel fry ;
<document> "doc" set <document> "doc" set
"Hello world" "doc" get set-doc-string "Hello world" "doc" get set-doc-string
[ { 0 0 } ] [ { 0 0 } "doc" get T{ one-word-elt } prev-elt ] unit-test [ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
[ { 0 0 } ] [ { 0 2 } "doc" get T{ 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 T{ 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 T{ one-word-elt } next-elt ] unit-test [ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
[ { 0 5 } ] [ { 0 5 } "doc" get T{ one-word-elt } next-elt ] unit-test [ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
<document> "doc" set <document> "doc" set
"Hello\nworld, how are\nyou?" "doc" get set-doc-string "Hello\nworld, how are\nyou?" "doc" get set-doc-string
[ { 2 4 } ] [ "doc" get doc-end ] unit-test [ { 2 4 } ] [ "doc" get doc-end ] unit-test
[ { 0 0 } ] [ { 0 3 } "doc" get T{ line-elt } prev-elt ] unit-test [ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
[ { 0 3 } ] [ { 1 3 } "doc" get T{ line-elt } prev-elt ] unit-test [ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
[ { 2 4 } ] [ { 2 1 } "doc" get T{ line-elt } next-elt ] unit-test [ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io kernel math models namespaces make USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories sequences strings splitting combinators unicode.categories
math.order math.ranges ; math.order math.ranges fry ;
IN: documents IN: documents
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ; : +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
@ -150,7 +150,7 @@ GENERIC: next-elt ( loc document elt -- newloc )
: elt-string ( loc document elt -- string ) : elt-string ( loc document elt -- string )
[ prev/next-elt ] [ drop ] 2bi doc-range ; [ prev/next-elt ] [ drop ] 2bi doc-range ;
TUPLE: char-elt ; SINGLETON: char-elt
: (prev-char) ( loc document quot -- loc ) : (prev-char) ( loc document quot -- loc )
{ {
@ -172,7 +172,7 @@ M: char-elt prev-elt
M: char-elt next-elt M: char-elt next-elt
drop [ drop 1 +col ] (next-char) ; drop [ drop 1 +col ] (next-char) ;
TUPLE: one-char-elt ; SINGLETON: one-char-elt
M: one-char-elt prev-elt 2drop ; 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 ; : ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot ) : break-detector ( ? -- quot )
[ [ blank? ] dip xor ] curry ; inline '[ blank? _ xor ] ; inline
: (prev-word) ( ? col str -- col ) : (prev-word) ( ? col str -- col )
rot break-detector find-last-from drop ?1+ ; 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 [ rot break-detector find-from drop ] keep
over not [ nip length ] [ drop ] if ; over not [ nip length ] [ drop ] if ;
TUPLE: one-word-elt ; SINGLETON: one-word-elt
M: one-word-elt prev-elt M: one-word-elt prev-elt
drop drop
@ -205,7 +205,7 @@ M: one-word-elt next-elt
drop drop
[ [ f ] 2dip (next-word) ] (word-elt) ; [ [ f ] 2dip (next-word) ] (word-elt) ;
TUPLE: word-elt ; SINGLETON: word-elt
M: word-elt prev-elt M: word-elt prev-elt
drop drop
@ -217,7 +217,7 @@ M: word-elt next-elt
[ [ ((word-elt)) (next-word) ] (word-elt) ] [ [ ((word-elt)) (next-word) ] (word-elt) ]
(next-char) ; (next-char) ;
TUPLE: one-line-elt ; SINGLETON: one-line-elt
M: one-line-elt prev-elt M: one-line-elt prev-elt
2drop first 0 2array ; 2drop first 0 2array ;
@ -225,7 +225,7 @@ M: one-line-elt prev-elt
M: one-line-elt next-elt M: one-line-elt next-elt
drop [ first dup ] dip doc-line length 2array ; drop [ first dup ] dip doc-line length 2array ;
TUPLE: line-elt ; SINGLETON: line-elt
M: line-elt prev-elt M: line-elt prev-elt
2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ; 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= drop over first over last-line# number=
[ nip doc-end ] [ drop 1 +line ] if ; [ nip doc-end ] [ drop 1 +line ] if ;
TUPLE: doc-elt ; SINGLETON: doc-elt
M: doc-elt prev-elt 3drop { 0 0 } ; M: doc-elt prev-elt 3drop { 0 0 } ;

View File

@ -8,7 +8,7 @@ IN: ui.gadgets.editors.tests
<editor> "editor" set <editor> "editor" set
"editor" get [ "editor" get [
"foo bar" "editor" get set-editor-string "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 "editor" get gadget-selection
] with-grafted-gadget ] with-grafted-gadget
] unit-test ] unit-test
@ -17,7 +17,7 @@ IN: ui.gadgets.editors.tests
<editor> "editor" set <editor> "editor" set
"editor" get [ "editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string "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 "editor" get gadget-selection
] with-grafted-gadget ] with-grafted-gadget
] unit-test ] unit-test

View File

@ -291,9 +291,9 @@ M: editor gadget-text* editor-string % ;
: mouse-elt ( -- element ) : mouse-elt ( -- element )
hand-click# get { hand-click# get {
{ 1 T{ one-char-elt } } { 1 one-char-elt }
{ 2 T{ one-word-elt } } { 2 one-word-elt }
} at T{ one-line-elt } or ; } at one-line-elt or ;
: drag-direction? ( loc editor -- ? ) : drag-direction? ( loc editor -- ? )
editor-mark* before? ; editor-mark* before? ;
@ -356,34 +356,34 @@ M: editor gadget-text* editor-string % ;
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
editor-select ; 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 -- ) : position-caret ( editor -- )
mouse-elt dup T{ one-char-elt } = mouse-elt dup one-char-elt =
[ drop dup extend-selection dup mark>> click-loc ] [ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ; [ select-elt ] if ;
: insert-newline ( editor -- ) "\n" swap user-input* drop ; : insert-newline ( editor -- ) "\n" swap user-input* drop ;
: delete-next-character ( editor -- ) : delete-next-character ( editor -- )
T{ char-elt } editor-delete ; char-elt editor-delete ;
: delete-previous-character ( editor -- ) : delete-previous-character ( editor -- )
T{ char-elt } editor-backspace ; char-elt editor-backspace ;
: delete-previous-word ( editor -- ) : delete-previous-word ( editor -- )
T{ word-elt } editor-delete ; word-elt editor-delete ;
: delete-next-word ( editor -- ) : delete-next-word ( editor -- )
T{ word-elt } editor-backspace ; word-elt editor-backspace ;
: delete-to-start-of-line ( editor -- ) : delete-to-start-of-line ( editor -- )
T{ one-line-elt } editor-delete ; one-line-elt editor-delete ;
: delete-to-end-of-line ( editor -- ) : delete-to-end-of-line ( editor -- )
T{ one-line-elt } editor-backspace ; one-line-elt editor-backspace ;
editor "general" f { editor "general" f {
{ T{ key-down f f "DELETE" } delete-next-character } { T{ key-down f f "DELETE" } delete-next-character }
@ -415,7 +415,7 @@ editor "clipboard" f {
dup selection-start/end drop dup selection-start/end drop
over set-caret mark>caret over set-caret mark>caret
] [ ] [
T{ char-elt } editor-prev char-elt editor-prev
] if ; ] if ;
: next-character ( editor -- ) : next-character ( editor -- )
@ -423,20 +423,20 @@ editor "clipboard" f {
dup selection-start/end nip dup selection-start/end nip
over set-caret mark>caret over set-caret mark>caret
] [ ] [
T{ char-elt } editor-next char-elt editor-next
] if ; ] 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 { editor "caret-motion" f {
{ T{ button-down } position-caret } { T{ button-down } position-caret }
@ -456,11 +456,11 @@ editor "caret-motion" f {
#! The with-datastack is a kludge to make it infer. Stupid. #! The with-datastack is a kludge to make it infer. Stupid.
model>> 1array [ clear-doc ] with-datastack drop ; 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 ) : selected-word ( editor -- string )
dup gadget-selection? dup gadget-selection?
@ -468,34 +468,34 @@ editor "caret-motion" f {
gadget-selection ; gadget-selection ;
: select-previous-character ( editor -- ) : select-previous-character ( editor -- )
T{ char-elt } editor-select-prev ; char-elt editor-select-prev ;
: select-next-character ( editor -- ) : select-next-character ( editor -- )
T{ char-elt } editor-select-next ; char-elt editor-select-next ;
: select-previous-line ( editor -- ) : select-previous-line ( editor -- )
T{ line-elt } editor-select-prev ; line-elt editor-select-prev ;
: select-next-line ( editor -- ) : select-next-line ( editor -- )
T{ line-elt } editor-select-next ; line-elt editor-select-next ;
: select-previous-word ( editor -- ) : select-previous-word ( editor -- )
T{ word-elt } editor-select-prev ; word-elt editor-select-prev ;
: select-next-word ( editor -- ) : select-next-word ( editor -- )
T{ word-elt } editor-select-next ; word-elt editor-select-next ;
: select-start-of-line ( editor -- ) : select-start-of-line ( editor -- )
T{ one-line-elt } editor-select-prev ; one-line-elt editor-select-prev ;
: select-end-of-line ( editor -- ) : select-end-of-line ( editor -- )
T{ one-line-elt } editor-select-next ; one-line-elt editor-select-next ;
: select-start-of-document ( editor -- ) : select-start-of-document ( editor -- )
T{ doc-elt } editor-select-prev ; doc-elt editor-select-prev ;
: select-end-of-document ( editor -- ) : select-end-of-document ( editor -- )
T{ doc-elt } editor-select-next ; doc-elt editor-select-next ;
editor "selection" f { editor "selection" f {
{ T{ button-down f { S+ } 1 } extend-selection } { T{ button-down f { S+ } 1 } extend-selection }

View File

@ -53,7 +53,7 @@ M: interactor ungraft*
: word-at-loc ( loc interactor -- word ) : word-at-loc ( loc interactor -- word )
over [ over [
[ model>> T{ one-word-elt } elt-string ] keep [ model>> one-word-elt elt-string ] keep
interactor-use assoc-stack interactor-use assoc-stack
] [ ] [
2drop f 2drop f