dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
-: editor-caret* ( editor -- loc ) caret>> value>> ;
+: editor-caret ( editor -- loc ) caret>> value>> ;
-: editor-mark* ( editor -- loc ) mark>> value>> ;
+: editor-mark ( editor -- loc ) mark>> value>> ;
: set-caret ( loc editor -- )
[ model>> validate-loc ] keep
caret>> set-model ;
: change-caret ( editor quot -- )
- [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
+ [ [ [ editor-caret ] [ model>> ] bi ] dip call ] [ drop ] 2bi
set-caret ; inline
: mark>caret ( editor -- )
- [ editor-caret* ] [ mark>> ] bi set-model ;
+ [ editor-caret ] [ mark>> ] bi set-model ;
: change-caret&mark ( editor quot -- )
[ change-caret ] [ drop mark>caret ] 2bi ; inline
[ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
: caret-loc ( editor -- loc )
- [ editor-caret* ] keep loc>point ;
+ [ editor-caret ] keep loc>point ;
: caret-dim ( editor -- dim )
line-height 0 swap 2array ;
] with-editor-translation ;
: selection-start/end ( editor -- start end )
- [ editor-mark* ] [ editor-caret* ] bi sort-pair ;
+ [ editor-mark ] [ editor-caret ] bi sort-pair ;
: (draw-selection) ( x1 x2 -- )
over -
} at one-line-elt or ;
: drag-direction? ( loc editor -- ? )
- editor-mark* before? ;
+ editor-mark before? ;
: drag-selection-caret ( loc editor element -- loc )
[
: drag-selection-mark ( loc editor element -- loc )
[
[ drag-direction? not ] keep
- [ editor-mark* ] [ model>> ] bi
+ [ editor-mark ] [ model>> ] bi
] dip prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark )
over gadget-selection? [
drop remove-selection
] [
- [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
+ [ [ [ editor-caret ] [ model>> ] bi ] dip call ]
[ drop model>> ]
2bi remove-doc-range
] if ; inline
tuck caret>> set-model mark>> set-model ;
: select-elt ( editor elt -- )
- [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
+ [ [ [ editor-caret ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
editor-select ;
: start-of-document ( editor -- ) doc-elt editor-prev ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.tools.listener.completion ;
+IN: ui.tools.listener.completion.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs calendar colors documents fry kernel
+sets splitting math math.vectors models.delay models.filter
+combinators.short-circuit parser present sequences tools.completion
+ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass
+ui.gadgets.scrollers ui.gadgets.tables
+ui.gadgets.theme ui.gadgets.worlds ui.gadgets.wrappers ui.gestures
+ui.render ui.tools.listener.history ;
+IN: ui.tools.listener.completion
+
+: complete-IN:/USE:? ( tokens -- ? )
+ 2 short tail* { "IN:" "USE:" } intersects? ;
+
+: chop-; ( seq -- seq' )
+ { ";" } split1-last [ ] [ ] ?if ;
+
+: complete-USING:? ( tokens -- ? )
+ chop-; { "USING:" } intersects? ;
+
+: up-to-caret ( caret document -- string )
+ [ { 0 0 } ] 2dip doc-range ;
+
+: vocab-completion? ( interactor -- ? )
+ [ editor-caret ] [ model>> ] bi up-to-caret " \r\n" split
+ { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ;
+
+! We don't directly depend on the listener tool but we use a couple
+! of slots
+SLOT: interactor
+SLOT: history
+
+TUPLE: completion-popup < wrapper table interactor element ;
+
+: find-completion-popup ( gadget -- popup )
+ [ completion-popup? ] find-parent ;
+
+SINGLETON: completion-renderer
+M: completion-renderer row-columns drop present 1array ;
+M: completion-renderer row-value drop ;
+
+: <completion-model> ( editor quot -- model )
+ [ one-word-elt <element-model> 1/3 seconds <delay> ] dip
+ '[ @ keys 1000 short head ] <filter> ;
+
+M: completion-popup hide-glass-hook
+ interactor>> f >>completion-popup request-focus ;
+
+: hide-completion-popup ( popup -- )
+ find-world hide-glass ;
+
+: completion-loc/doc ( popup -- loc doc )
+ interactor>> [ editor-caret ] [ model>> ] bi ;
+
+: accept-completion ( item table -- )
+ find-completion-popup
+ [ [ present ] [ completion-loc/doc ] bi* one-word-elt set-elt-string ]
+ [ hide-completion-popup ]
+ bi ;
+
+: <completion-table> ( interactor quot -- table )
+ <completion-model> <table>
+ monospace-font >>font
+ t >>selection-required?
+ completion-renderer >>renderer
+ dup '[ _ accept-completion ] >>action ;
+
+: <completion-scroller> ( object -- object )
+ <limited-scroller>
+ { 300 120 } >>min-dim
+ { 300 120 } >>max-dim ;
+
+: <completion-popup> ( interactor quot -- popup )
+ [ completion-popup new-gadget ] 2dip
+ [ drop >>interactor ] [ <completion-table> >>table ] 2bi
+ dup table>> <completion-scroller> add-gadget
+ white <solid> >>interior ;
+
+completion-popup H{
+ { T{ key-down f f "ESC" } [ hide-completion-popup ] }
+ { T{ key-down f f "TAB" } [ table>> row-action ] }
+ { T{ key-down f f " " } [ table>> row-action ] }
+} set-gestures
+
+CONSTANT: completion-popup-offset { -4 0 }
+
+: (completion-popup-loc) ( interactor element -- loc )
+ [ drop screen-loc ] [
+ [ [ [ editor-caret ] [ model>> ] bi ] dip prev-elt ] [ drop ] 2bi
+ loc>point
+ ] 2bi v+ completion-popup-offset v+ ;
+
+: completion-popup-loc-1 ( interactor element -- loc )
+ [ (completion-popup-loc) ] [ drop caret-dim ] 2bi v+ ;
+
+: completion-popup-loc-2 ( interactor element popup -- loc )
+ [ (completion-popup-loc) ] dip pref-dim { 0 1 } v* v- ;
+
+: completion-popup-fits? ( interactor element popup -- ? )
+ [ [ completion-popup-loc-1 ] dip pref-dim v+ ]
+ [ 2drop find-world dim>> ]
+ 3bi [ second ] bi@ <= ;
+
+: completion-popup-loc ( interactor element popup -- loc )
+ 3dup completion-popup-fits?
+ [ drop completion-popup-loc-1 ]
+ [ completion-popup-loc-2 ]
+ if ;
+
+: show-completion-popup ( interactor quot element -- )
+ [ nip ] [ drop <completion-popup> ] 3bi
+ [ nip >>completion-popup drop ]
+ [ [ 2drop find-world ] [ 2nip ] [ completion-popup-loc ] 3tri ] 3bi
+ show-glass ;
+
+: word-completion-popup ( interactor -- )
+ dup vocab-completion?
+ [ vocabs-matching ] [ words-matching ] ? '[ [ { } ] _ if-empty ]
+ one-word-elt show-completion-popup ;
+
+: history-matching ( interactor -- alist )
+ history>> elements>>
+ [ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
+ <reversed> ;
+
+: history-completion-popup ( interactor -- )
+ dup '[ drop _ history-matching ] one-line-elt show-completion-popup ;
+
+: recall-previous ( interactor -- )
+ history>> history-recall-previous ;
+
+: recall-next ( interactor -- )
+ history>> history-recall-next ;
+
+: selected-word ( editor -- word )
+ dup completion-popup>> [
+ [ table>> selected-row drop ] [ hide-completion-popup ] bi
+ ] [
+ selected-token dup search [ ] [ no-word ] ?if
+ ] ?if ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: documents namespaces tools.test io.styles
+ui.tools.listener.history kernel ;
+IN: ui.tools.listener.history.tests
+
+[ ] [ <document> "d" set ] unit-test
+[ ] [ "d" get <history> "h" set ] unit-test
+
+[ ] [ "1" "d" get set-doc-string ] unit-test
+[ T{ input f "1" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "2" "d" get set-doc-string ] unit-test
+[ T{ input f "2" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "3" "d" get set-doc-string ] unit-test
+[ T{ input f "3" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "" "d" get set-doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "3" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "2" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "1" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "1" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-next ] unit-test
+[ "2" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "22" "d" get set-doc-string ] unit-test
+
+[ ] [ "h" get history-recall-next ] unit-test
+[ "3" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "22" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "1" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "222" "d" get set-doc-string ] unit-test
+[ T{ input f "222" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+
+[ "22" ] [ "d" get doc-string ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors documents io.styles kernel math math.order
+sequences fry ;
+IN: ui.tools.listener.history
+
+TUPLE: history document elements index ;
+
+: <history> ( document -- history )
+ V{ } clone 0 history boa ;
+
+: history-add ( history -- input )
+ dup elements>> length 1+ >>index
+ [ document>> doc-string [ <input> ] [ empty? ] bi ] keep
+ '[ [ _ elements>> push ] keep ] unless ;
+
+: save-history ( history -- )
+ [ document>> doc-string ] keep
+ '[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
+ unless-empty ;
+
+: update-document ( history -- )
+ [ [ index>> ] [ elements>> ] bi nth string>> ]
+ [ document>> ] bi
+ set-doc-string ;
+
+: change-history-index ( history i -- )
+ over elements>> length 1-
+ '[ _ + _ min 0 max ] change-index drop ;
+
+: history-recall ( history i -- )
+ [ [ elements>> empty? ] keep ] dip '[
+ _
+ [ save-history ]
+ [ _ change-history-index ]
+ [ update-document ]
+ tri
+ ] unless ;
+
+: history-recall-previous ( history -- )
+ -1 history-recall ;
+
+: history-recall-next ( history -- )
+ 1 history-recall ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: inspector kernel help help.markup io io.styles models math.vectors
-strings splitting namespaces parser quotations sequences vocabs words
-continuations prettyprint listener debugger threads boxes
-concurrency.flags math arrays generic accessors combinators
-combinators.short-circuit combinators.smart
-assocs fry generic.standard.engines.tuple
-tools.vocabs concurrency.mailboxes vocabs.parser calendar
-models.delay models.filter documents hashtables sets destructors lexer
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled
-ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
-ui.gadgets.packs ui.gadgets.tracks ui.gadgets.borders
-ui.gadgets.frames ui.gadgets.grids ui.gadgets.status-bar
-ui.gadgets.viewports ui.gadgets.wrappers ui.gestures ui.operations
-ui.tools.browser ui.tools.debugger ui.gadgets.theme
-ui.tools.inspector ui.tools.common ui ;
+USING: accessors arrays assocs calendar combinators
+combinators.short-circuit compiler.units concurrency.flags
+concurrency.mailboxes continuations destructors documents fry generic
+generic.standard.engines.tuple hashtables help help.markup io
+io.styles kernel lexer listener math models models.delay models.filter
+namespaces parser prettyprint quotations sequences strings threads
+tools.vocabs ui ui.commands ui.gadgets ui.gadgets.buttons
+ui.gadgets.editors ui.gadgets.frames ui.gadgets.grids
+ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.status-bar ui.gadgets.tracks ui.gestures ui.operations
+ui.tools.browser ui.tools.common ui.tools.debugger
+ui.tools.listener.completion ui.tools.listener.history vocabs
+vocabs.parser words ;
IN: ui.tools.listener
! If waiting is t, we're waiting for user input, and invoking
assoc-stack
] if ;
-: complete-IN:/USE:? ( tokens -- ? )
- 2 short tail* { "IN:" "USE:" } intersects? ;
-
-: chop-; ( seq -- seq' )
- { ";" } split1-last [ ] [ ] ?if ;
-
-: complete-USING:? ( tokens -- ? )
- chop-; { "USING:" } intersects? ;
-
-: up-to-caret ( caret document -- string )
- [ { 0 0 } ] 2dip doc-range ;
-
-: vocab-completion? ( interactor -- ? )
- [ editor-caret ] [ model>> ] bi up-to-caret " \r\n" split
- { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ;
-
: <word-model> ( interactor -- model )
[ one-word-elt <element-model> 1/3 seconds <delay> ] keep
'[
: <interactor> ( output -- gadget )
interactor new-editor
- V{ } clone >>history
<flag> >>flag
dup <word-model> >>help
+ dup model>> <history> >>history
swap >>output ;
M: interactor graft*
: print-input ( object interactor -- )
output>> [ (print-input) ] with-output-stream* ;
-: add-interactor-history ( input interactor -- )
- over string>> empty? [ 2drop ] [ history>> adjoin ] if ;
-
: interactor-continue ( obj interactor -- )
mailbox>> mailbox-put ;
: interactor-finish ( interactor -- )
- [ editor-string <input> ] keep
- [ print-input ]
- [ add-interactor-history ]
- [ clear-editor drop ]
- 2tri ;
+ [ history>> history-add ] keep
+ [ print-input ] [ clear-editor drop ] 2bi ;
: interactor-eof ( interactor -- )
dup interactor-busy? [
2bi ;
: quot-action ( interactor -- lines )
- [ [ editor-string <input> ] keep add-interactor-history ]
- [ control-value ]
- [ select-all ]
- tri ;
+ [ history>> history-add drop ] [ control-value ] [ select-all ] tri
+ [ parse-lines ] with-compilation-unit ;
: hide-popup ( listener -- )
dup popup>> track-remove
]
} cond ;
+: pass-to-popup? ( gesture interactor -- ? )
+ [ [ key-down? ] [ key-up? ] bi or ]
+ [ completion-popup>> ]
+ bi* and ;
+
+M: interactor handle-gesture
+ 2dup pass-to-popup? [
+ 2dup completion-popup>>
+ focusable-child resend-gesture
+ [ call-next-method ] [ 2drop f ] if
+ ] [ call-next-method ] if ;
+
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
{ T{ key-down f { C+ } "k" } clear-editor }
} define-command-map
+interactor "completion" f {
+ { T{ key-down f f "TAB" } word-completion-popup }
+ { T{ key-down f { C+ } "p" } recall-previous }
+ { T{ key-down f { C+ } "n" } recall-next }
+ { T{ key-down f { C+ } "r" } history-completion-popup }
+} define-command-map
+
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
"handbook" ($link) ". To see a list of keyboard shortcuts," print
[ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- [ com-end ] [ call-next-method ] bi ;
-
-! Foo
-USING: summary ui.gadgets.labels ui.gadgets.tables colors ui.render
-ui.gadgets.worlds ui.gadgets.glass tools.completion ui.gadgets
-present ;
-USE: tools.completion
-
-: <summary-gadget> ( model -- gadget )
- [ summary ] <filter> <label-control> ;
-
-TUPLE: completion-popup < wrapper table interactor element ;
-
-: find-completion-popup ( gadget -- popup )
- [ completion-popup? ] find-parent ;
-
-SINGLETON: completion-renderer
-M: completion-renderer row-columns drop present 1array ;
-M: completion-renderer row-value drop ;
-
-: <completion-model> ( editor quot -- model )
- [ one-word-elt <element-model> 1/3 seconds <delay> ] dip
- '[ @ keys 1000 short head ] <filter> ;
-
-M: completion-popup hide-glass-hook
- interactor>> f >>completion-popup request-focus ;
-
-: hide-completion-popup ( popup -- )
- find-world hide-glass ;
-
-: completion-loc/doc ( popup -- loc doc )
- interactor>> [ editor-caret ] [ model>> ] bi ;
-
-: accept-completion ( item table -- )
- find-completion-popup
- [ [ present ] [ completion-loc/doc ] bi* one-word-elt set-elt-string ]
- [ hide-completion-popup ]
- bi ;
-
-: <completion-table> ( interactor quot -- table )
- <completion-model> <table>
- monospace-font >>font
- t >>selection-required?
- completion-renderer >>renderer
- dup '[ _ accept-completion ] >>action ;
-
-: <completion-scroller> ( object -- object )
- <limited-scroller>
- { 300 120 } >>min-dim
- { 300 120 } >>max-dim ;
-
-: <completion-popup> ( interactor quot -- popup )
- [ completion-popup new-gadget ] 2dip
- [ drop >>interactor ] [ <completion-table> >>table ] 2bi
- dup table>> <completion-scroller> add-gadget
- white <solid> >>interior ;
-
-completion-popup H{
- { T{ key-down f f "ESC" } [ hide-completion-popup ] }
- { T{ key-down f f "TAB" } [ table>> row-action ] }
- { T{ key-down f f " " } [ table>> row-action ] }
-} set-gestures
-
-CONSTANT: completion-popup-offset { -4 0 }
-
-: (completion-popup-loc) ( interactor element -- loc )
- [ drop screen-loc ] [
- [ [ [ editor-caret ] [ model>> ] bi ] dip prev-elt ] [ drop ] 2bi
- loc>point
- ] 2bi v+ completion-popup-offset v+ ;
-
-: completion-popup-loc-1 ( interactor element -- loc )
- [ (completion-popup-loc) ] [ drop caret-dim ] 2bi v+ ;
-
-: completion-popup-loc-2 ( interactor element popup -- loc )
- [ (completion-popup-loc) ] dip pref-dim { 0 1 } v* v- ;
-
-: completion-popup-fits? ( interactor element popup -- ? )
- [ [ completion-popup-loc-1 ] dip pref-dim v+ ]
- [ 2drop find-world dim>> ]
- 3bi [ second ] bi@ <= ;
-
-: completion-popup-loc ( interactor element popup -- loc )
- 3dup completion-popup-fits?
- [ drop completion-popup-loc-1 ]
- [ completion-popup-loc-2 ]
- if ;
-
-: show-completion-popup ( interactor quot element -- )
- [ nip ] [ drop <completion-popup> ] 3bi
- [ nip >>completion-popup drop ]
- [ [ 2drop find-world ] [ 2nip ] [ completion-popup-loc ] 3tri ] 3bi
- show-glass ;
-
-: word-completion-popup ( interactor -- )
- dup vocab-completion?
- [ vocabs-matching ] [ words-matching ] ? '[ [ { } ] _ if-empty ]
- one-word-elt show-completion-popup ;
-
-: history-matching ( interactor -- alist )
- history>>
- [ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
- <reversed> ;
-
-: history-completion-popup ( interactor -- )
- dup '[ drop _ history-matching ] one-line-elt show-completion-popup ;
-
-: pass-to-popup? ( gesture interactor -- ? )
- [ [ key-down? ] [ key-up? ] bi or ]
- [ completion-popup>> ]
- bi* and ;
-
-M: interactor handle-gesture
- 2dup pass-to-popup? [
- 2dup completion-popup>>
- focusable-child resend-gesture
- [ call-next-method ] [ 2drop f ] if
- ] [ call-next-method ] if ;
-
-: selected-word ( editor -- word )
- dup completion-popup>> [
- [ table>> selected-row drop ] [ hide-completion-popup ] bi
- ] [
- selected-token dup search [ ] [ no-word ] ?if
- ] ?if ;
-
-interactor "completion" f {
- { T{ key-down f f "TAB" } word-completion-popup }
- { T{ key-down f { C+ } "p" } history-completion-popup }
-} define-command-map
\ No newline at end of file
+ [ com-end ] [ call-next-method ] bi ;
\ No newline at end of file
} define-operation
[ vocab-spec? ] \ run H{
- { +keyboard+ T{ key-down f { C+ } "r" } }
{ +listener+ t }
} define-operation
[ vocab? ] \ test H{
- { +keyboard+ T{ key-down f { C+ } "t" } }
{ +listener+ t }
} define-operation
: com-profile ( quot -- ) profile profiler-window ;
[ quotation? ] \ com-profile H{
- { +keyboard+ T{ key-down f { C+ } "r" } }
+ { +keyboard+ T{ key-down f { C+ } "f" } }
{ +listener+ t }
} define-operation
-USE: ui.gadgets.tables
-
! Operations -> commands
source-editor
"word"
"quotation"
"These commands operate on the entire contents of the input area."
[ ]
-[ quot-action [ parse-lines ] with-compilation-unit ]
+[ quot-action ]
define-operation-map