1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs calendar colors colors.constants
4 combinators combinators.short-circuit definitions.icons
5 documents documents.elements fonts fry generic help.vocabs
6 kernel math math.vectors models.arrow models.delay parser
7 present sequences sets splitting tools.completion ui.commands
8 ui.gadgets ui.gadgets.editors ui.gadgets.glass
9 ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables
10 ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.wrappers
11 ui.gestures ui.images ui.operations ui.pens.solid ui.theme
12 ui.theme.images ui.tools.common ui.tools.listener.history
13 ui.tools.listener.popups vocabs words ;
14 IN: ui.tools.listener.completion
16 ! We don't directly depend on the listener tool but we use a few slots
20 : history-list ( interactor -- alist )
22 [ dup string>> H{ { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
25 : history-completions ( short interactor -- seq )
26 history-list over empty? [ nip ] [ members completions ] if ;
28 TUPLE: word-completion manifest ;
29 C: <word-completion> word-completion
31 SINGLETONS: vocab-completion color-completion char-completion
32 path-completion history-completion ;
33 UNION: definition-completion word-completion vocab-completion ;
34 UNION: listener-completion definition-completion
35 color-completion char-completion path-completion history-completion ;
37 GENERIC: completion-quot ( interactor completion-mode -- quot )
39 : (completion-quot) ( interactor completion-mode quot -- quot' )
40 2nip '[ [ { } ] _ if-empty ] ; inline
42 M: word-completion completion-quot [ words-matching ] (completion-quot) ;
43 M: vocab-completion completion-quot [ vocabs-matching ] (completion-quot) ;
44 M: color-completion completion-quot [ colors-matching ] (completion-quot) ;
45 M: char-completion completion-quot [ chars-matching ] (completion-quot) ;
46 M: path-completion completion-quot [ paths-matching ] (completion-quot) ;
47 M: history-completion completion-quot drop '[ _ history-completions ] ;
49 GENERIC: completion-element ( completion-mode -- element )
51 M: object completion-element drop word-start-elt ;
52 M: history-completion completion-element drop one-line-elt ;
54 GENERIC: completion-banner ( completion-mode -- string )
56 M: word-completion completion-banner drop "Words" ;
57 M: vocab-completion completion-banner drop "Vocabularies" ;
58 M: color-completion completion-banner drop "Colors" ;
59 M: char-completion completion-banner drop "Unicode code point names" ;
60 M: path-completion completion-banner drop "Paths" ;
61 M: history-completion completion-banner drop "Input history" ;
63 ! Completion modes also implement the row renderer protocol
64 M: listener-completion row-columns drop present 1array ;
66 M: definition-completion prototype-row
67 drop \ + definition-icon <image-name> "" 2array ;
69 M: definition-completion row-columns
71 [ definition-icon <image-name> ]
75 M: word-completion row-color
76 [ vocabulary>> ] [ manifest>> ] bi* {
77 { [ dup not ] [ COLOR: black ] }
78 { [ 2dup search-vocab-names>> in? ] [ COLOR: black ] }
79 { [ over ".private" tail? ] [ COLOR: dark-red ] }
83 M: vocab-completion row-color
85 name>> ".private" tail? COLOR: dark-red COLOR: black ?
86 ] [ drop COLOR: dark-gray ] if ;
88 M: color-completion row-color
91 : up-to-caret ( caret document -- string )
92 [ { 0 0 } ] 2dip doc-range ;
94 : completion-mode ( interactor -- symbol )
95 [ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
97 { [ dup complete-vocab? ] [ 2drop vocab-completion ] }
98 { [ dup complete-char? ] [ 2drop char-completion ] }
99 { [ dup complete-color? ] [ 2drop color-completion ] }
100 { [ dup complete-pathname? ] [ 2drop path-completion ] }
101 [ drop <word-completion> ]
104 TUPLE: completion-popup < track interactor table completion-mode ;
106 : find-completion-popup ( gadget -- popup )
107 [ completion-popup? ] find-parent ;
109 : <completion-model> ( editor element quot -- model )
110 [ <element-model> 1/3 seconds <delay> ] dip
111 '[ @ keys 1000 short head ] <arrow> ;
113 M: completion-popup focusable-child* table>> ;
115 : completion-loc/doc/elt ( popup -- loc doc elt )
116 [ interactor>> [ editor-caret ] [ model>> ] bi ]
117 [ completion-mode>> completion-element ]
120 GENERIC: completion-string ( object -- string )
122 M: object completion-string present ;
124 : method-completion-string ( word -- string )
125 "method-generic" word-prop present ;
127 M: method completion-string method-completion-string ;
129 GENERIC# accept-completion-hook 1 ( item popup -- )
131 : insert-completion ( item popup -- )
132 [ completion-string ] [ completion-loc/doc/elt ] bi* set-elt-string ;
134 : accept-completion ( item table -- )
135 find-completion-popup
136 [ insert-completion ]
137 [ accept-completion-hook ]
141 : <completion-table> ( interactor completion-mode -- table )
142 [ completion-element ] [ completion-quot ] [ nip ] 2tri
143 [ <completion-model> ] dip <table>
144 monospace-font >>font
145 t >>selection-required?
150 dup '[ _ accept-completion ] >>action ;
152 : <completion-scroller> ( completion-popup -- scroller )
153 table>> <scroller> content-background <solid> >>interior ;
155 : <completion-popup> ( interactor completion-mode -- popup )
156 [ vertical completion-popup new-track ] 2dip
157 [ [ >>interactor ] [ >>completion-mode ] bi* ] [ <completion-table> >>table ] 2bi
158 dup [ <completion-scroller> ] [ completion-mode>> completion-banner ] bi
159 completion-color <framed-labeled> 1 track-add ;
162 { T{ key-down f f "TAB" } [ table>> row-action ] }
163 { T{ key-down f f " " } [ table>> row-action ] }
166 : show-completion-popup ( interactor mode -- )
167 [ completion-element ] [ <completion-popup> ] 2bi
168 show-listener-popup ;
170 : code-completion-popup ( interactor -- )
171 dup completion-mode show-completion-popup ;
173 : history-completion-popup ( interactor -- )
174 history-completion show-completion-popup ;
176 : recall-previous ( interactor -- )
177 history>> history-recall-previous ;
179 : recall-next ( interactor -- )
180 history>> history-recall-next ;
182 : completion-gesture ( gesture completion -- value/f operation/f )
184 [ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;
186 M: completion-popup handle-gesture ( gesture completion -- ? )
187 2dup completion-gesture dup [
188 [ nip hide-glass ] [ invoke-command ] 2bi* f
189 ] [ 2drop call-next-method ] if ;