1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs calendar colors combinators
5 combinators.short-circuit definitions.icons documents
6 documents.elements fonts generic help.vocabs kernel math
7 math.vectors models.arrow models.delay parser present sequences
8 sets splitting strings tools.completion ui.commands ui.gadgets
9 ui.gadgets.editors ui.gadgets.glass ui.gadgets.labeled
10 ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.tracks
11 ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.images
12 ui.operations ui.pens.solid ui.theme ui.theme.images
13 ui.tools.common ui.tools.listener.history
14 ui.tools.listener.popups unicode.data vocabs words ;
16 IN: ui.tools.listener.completion
18 ! We don't directly depend on the listener tool but we use a few slots
22 : history-list ( interactor -- alist )
24 [ dup string>> H{ { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
27 : history-completions ( short interactor -- seq )
28 history-list over empty? [ nip ] [ members completions ] if ;
30 TUPLE: word-completion manifest ;
31 C: <word-completion> word-completion
33 TUPLE: vocab-word-completion vocab-name ;
34 C: <vocab-word-completion> vocab-word-completion
36 SINGLETONS: vocab-completion color-completion char-completion
37 path-completion history-completion ;
38 UNION: definition-completion word-completion
39 vocab-word-completion vocab-completion ;
40 UNION: code-completion definition-completion
41 color-completion char-completion path-completion ;
42 UNION: listener-completion code-completion history-completion ;
44 GENERIC: completion-quot ( interactor completion-mode -- quot )
46 : (completion-quot) ( interactor completion-mode quot -- quot' )
47 2nip '[ [ { } ] _ if-empty ] ; inline
49 M: word-completion completion-quot [ words-matching ] (completion-quot) ;
50 M: vocab-word-completion completion-quot nip vocab-name>> '[ _ vocab-words-matching ] ;
51 M: vocab-completion completion-quot [ vocabs-matching ] (completion-quot) ;
52 M: color-completion completion-quot [ colors-matching ] (completion-quot) ;
53 M: char-completion completion-quot [ chars-matching ] (completion-quot) ;
54 M: path-completion completion-quot [ paths-matching ] (completion-quot) ;
55 M: history-completion completion-quot drop '[ _ history-completions ] ;
57 GENERIC: completion-element ( completion-mode -- element )
59 M: object completion-element drop word-start-elt ;
60 M: history-completion completion-element drop one-line-elt ;
62 GENERIC: completion-banner ( completion-mode -- string )
64 M: word-completion completion-banner drop "Words" ;
65 M: vocab-word-completion completion-banner drop "Words" ;
66 M: vocab-completion completion-banner drop "Vocabularies" ;
67 M: color-completion completion-banner drop "Colors" ;
68 M: char-completion completion-banner drop "Unicode code point names" ;
69 M: path-completion completion-banner drop "Paths" ;
70 M: history-completion completion-banner drop "Input history" ;
72 ! Completion modes also implement the row renderer protocol
73 M: listener-completion row-columns drop second 1array ;
74 M: listener-completion row-summary drop first ;
76 M: char-completion row-columns
77 drop first [ name-map at 1string ] keep 2array ;
79 M: definition-completion prototype-row
80 drop \ + definition-icon <image-name> "" 2array ;
82 M: definition-completion row-columns
83 drop first2 [ definition-icon <image-name> ] dip 2array ;
85 M: word-completion row-color
86 [ first vocabulary>> ] [ manifest>> ] bi* {
87 { [ dup not ] [ text-color ] }
88 { [ 2dup search-vocab-names>> in? ] [ text-color ] }
89 { [ over ".private" tail? ] [ COLOR: dark-red ] }
93 M: vocab-word-completion row-color 2drop COLOR: black ;
95 M: vocab-completion row-color
96 drop first dup vocab? [
97 name>> ".private" tail? COLOR: dark-red text-color ?
98 ] [ drop COLOR: dark-gray ] if ;
100 M: color-completion row-color
101 drop second named-color ;
103 : up-to-caret ( caret document -- string )
104 [ { 0 0 } ] 2dip doc-range ;
106 : completion-mode ( interactor -- symbol )
107 [ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
109 { [ dup complete-vocab? ] [ 2drop vocab-completion ] }
110 { [ dup complete-char? ] [ 2drop char-completion ] }
111 { [ dup complete-color? ] [ 2drop color-completion ] }
112 { [ dup complete-pathname? ] [ 2drop path-completion ] }
113 { [ dup complete-vocab-words? ] [ nip harvest second <vocab-word-completion> ] }
114 [ drop <word-completion> ]
117 TUPLE: completion-popup < track interactor table completion-mode ;
119 : find-completion-popup ( gadget -- popup )
120 [ completion-popup? ] find-parent ;
122 : <completion-model> ( editor element quot -- model )
123 [ <element-model> ] dip '[ @ >alist 100 cramp head ] <arrow> ;
125 M: completion-popup focusable-child* table>> ;
127 : completion-loc/doc/elt ( popup -- loc doc elt )
128 [ interactor>> [ editor-caret ] [ model>> ] bi ]
129 [ completion-mode>> completion-element ]
132 GENERIC#: accept-completion-hook 1 ( item popup -- )
134 : insert-completion ( item popup -- )
135 completion-loc/doc/elt set-elt-string ;
137 : unpack-completion ( item -- object string )
138 first2 over string? [ drop dup ] when ;
140 : accept-completion ( item table -- )
141 [ unpack-completion ] [ find-completion-popup ] bi*
142 [ insert-completion ] [ accept-completion-hook ] bi ;
144 : <completion-table> ( interactor completion-mode -- table )
145 [ completion-element ] [ completion-quot ] [ nip ] 2tri
146 [ <completion-model> ] dip <table>
147 monospace-font >>font
148 t >>selection-required?
153 dup '[ _ accept-completion ] >>action
154 [ hide-glass ] >>hook ;
156 : <completion-scroller> ( completion-popup -- scroller )
157 table>> <scroller> white-interior ;
159 : <completion-popup> ( interactor completion-mode -- popup )
160 [ vertical completion-popup new-track ] 2dip
161 [ [ >>interactor ] [ >>completion-mode ] bi* ] [ <completion-table> >>table ] 2bi
162 dup [ <completion-scroller> ] [ completion-mode>> completion-banner ] bi
163 completion-color <framed-labeled-gadget> 1 track-add ;
166 { T{ key-down f f "TAB" } [ table>> row-action ] }
167 { T{ key-down f f " " } [ table>> row-action ] }
170 : show-completion-popup ( interactor mode -- )
171 [ completion-element ] [ <completion-popup> ] 2bi
172 show-listener-popup ;
174 : code-completion-popup ( interactor -- )
175 dup completion-mode show-completion-popup ;
177 : history-completion-popup ( interactor -- )
178 history-completion show-completion-popup ;
180 : recall-previous ( interactor -- )
181 history>> history-recall-previous ;
183 : recall-next ( interactor -- )
184 history>> history-recall-next ;
186 : ?check-popup ( interactor -- interactor )
188 gadget-child dup completion-popup? [
189 completion-mode>> dup code-completion? [
190 over completion-mode =
191 [ dup popup>> hide-glass ] unless