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 documents documents.elements fry kernel words sets splitting math
5 math.vectors models.delay models.arrow combinators.short-circuit
6 parser present sequences tools.completion help.vocabs generic fonts
7 definitions.icons ui.images ui.commands ui.operations ui.gadgets
8 ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
9 ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled
10 ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid
11 ui.tools.listener.history combinators vocabs ui.tools.listener.popups ;
12 IN: ui.tools.listener.completion
14 ! We don't directly depend on the listener tool but we use a few slots
18 : history-list ( interactor -- alist )
20 [ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
23 TUPLE: word-completion manifest ;
24 C: <word-completion> word-completion
26 SINGLETONS: vocab-completion char-completion history-completion ;
27 UNION: definition-completion word-completion vocab-completion ;
28 UNION: listener-completion definition-completion char-completion history-completion ;
30 GENERIC: completion-quot ( interactor completion-mode -- quot )
32 : (completion-quot) ( interactor completion-mode quot -- quot' )
33 2nip '[ [ { } ] _ if-empty ] ; inline
35 M: word-completion completion-quot [ words-matching ] (completion-quot) ;
36 M: vocab-completion completion-quot [ vocabs-matching ] (completion-quot) ;
37 M: char-completion completion-quot [ chars-matching ] (completion-quot) ;
38 M: history-completion completion-quot drop '[ drop _ history-list ] ;
40 GENERIC: completion-element ( completion-mode -- element )
42 M: object completion-element drop word-start-elt ;
43 M: history-completion completion-element drop one-line-elt ;
45 GENERIC: completion-banner ( completion-mode -- string )
47 M: word-completion completion-banner drop "Words" ;
48 M: vocab-completion completion-banner drop "Vocabularies" ;
49 M: char-completion completion-banner drop "Unicode code point names" ;
50 M: history-completion completion-banner drop "Input history" ;
52 ! Completion modes also implement the row renderer protocol
53 M: listener-completion row-columns drop present 1array ;
55 M: definition-completion prototype-row
56 drop \ + definition-icon <image-name> "" 2array ;
58 M: definition-completion row-columns
60 [ definition-icon <image-name> ]
64 M: word-completion row-color
65 [ vocabulary>> ] [ manifest>> ] bi* {
66 { [ dup not ] [ COLOR: black ] }
67 { [ 2dup search-vocabs>> member-eq? ] [ COLOR: black ] }
68 { [ over ".private" tail? ] [ COLOR: dark-red ] }
72 M: vocab-completion row-color
73 drop vocab? COLOR: black COLOR: dark-gray ? ;
75 : complete-vocab? ( tokens -- ? )
76 1 short head* 2 short tail*
77 { "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" } intersects? ;
79 : chop-; ( seq -- seq' )
80 { ";" } split1-last [ ] [ ] ?if ;
82 : complete-vocab-list? ( tokens -- ? )
83 chop-; 1 short head* { "USING:" } intersects? ;
85 : complete-CHAR:? ( tokens -- ? )
86 2 short tail* "CHAR:" swap member? ;
88 : up-to-caret ( caret document -- string )
89 [ { 0 0 } ] 2dip doc-range ;
91 : completion-mode ( interactor -- symbol )
92 [ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
94 { [ dup { [ complete-vocab? ] [ complete-vocab-list? ] } 1|| ] [ 2drop vocab-completion ] }
95 { [ dup complete-CHAR:? ] [ 2drop char-completion ] }
96 [ drop <word-completion> ]
99 TUPLE: completion-popup < track interactor table completion-mode ;
101 : find-completion-popup ( gadget -- popup )
102 [ completion-popup? ] find-parent ;
104 : <completion-model> ( editor element quot -- model )
105 [ <element-model> 1/3 seconds <delay> ] dip
106 '[ @ keys 1000 short head ] <arrow> ;
108 M: completion-popup focusable-child* table>> ;
110 : completion-loc/doc/elt ( popup -- loc doc elt )
111 [ interactor>> [ editor-caret ] [ model>> ] bi ]
112 [ completion-mode>> completion-element ]
115 GENERIC: completion-string ( object -- string )
117 M: object completion-string present ;
119 : method-completion-string ( word -- string )
120 "method-generic" word-prop present ;
122 M: method completion-string method-completion-string ;
124 GENERIC# accept-completion-hook 1 ( item popup -- )
126 : insert-completion ( item popup -- )
127 [ completion-string ] [ completion-loc/doc/elt ] bi* set-elt-string ;
129 : accept-completion ( item table -- )
130 find-completion-popup
131 [ insert-completion ]
132 [ accept-completion-hook ]
136 : <completion-table> ( interactor completion-mode -- table )
137 [ completion-element ] [ completion-quot ] [ nip ] 2tri
138 [ <completion-model> ] dip <table>
139 monospace-font >>font
140 t >>selection-required?
145 dup '[ _ accept-completion ] >>action ;
147 : <completion-scroller> ( completion-popup -- scroller )
148 table>> <scroller> COLOR: white <solid> >>interior ;
150 : <completion-popup> ( interactor completion-mode -- popup )
151 [ vertical completion-popup new-track ] 2dip
152 [ [ >>interactor ] [ >>completion-mode ] bi* ] [ <completion-table> >>table ] 2bi
153 dup [ <completion-scroller> ] [ completion-mode>> completion-banner ] bi
154 <labeled-gadget> 1 track-add ;
157 { T{ key-down f f "TAB" } [ table>> row-action ] }
158 { T{ key-down f f " " } [ table>> row-action ] }
161 : show-completion-popup ( interactor mode -- )
162 [ completion-element ] [ <completion-popup> ] 2bi
163 show-listener-popup ;
165 : code-completion-popup ( interactor -- )
166 dup completion-mode show-completion-popup ;
168 : history-completion-popup ( interactor -- )
169 history-completion show-completion-popup ;
171 : recall-previous ( interactor -- )
172 history>> history-recall-previous ;
174 : recall-next ( interactor -- )
175 history>> history-recall-next ;
177 : completion-gesture ( gesture completion -- value/f operation/f )
179 [ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;
181 M: completion-popup handle-gesture ( gesture completion -- ? )
182 2dup completion-gesture dup [
183 [ nip hide-glass ] [ invoke-command ] 2bi* f
184 ] [ 2drop call-next-method ] if ;