1 ! Copyright (C) 2006 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays gadgets gadgets-labels gadgets-panes
5 gadgets-scrolling gadgets-text gadgets-theme
6 generic help tools kernel models sequences words
7 gadgets-borders gadgets-lists gadgets-workspace gadgets-listener
8 namespaces parser hashtables io completion styles strings
11 TUPLE: live-search field list ;
13 : search-gesture ( gesture live-search -- command/f )
14 live-search-list list-value object-operations
15 [ command-gesture = ] find-with nip ;
17 M: live-search handle-gesture* ( gadget gesture delegate -- ? )
18 drop over search-gesture dup [
19 over find-workspace hide-popup
20 >r live-search-list list-value r> invoke-command f
25 : find-live-search [ [ live-search? ] is? ] find-parent ;
27 : find-search-list find-live-search live-search-list ;
31 C: search-field ( -- gadget )
32 <editor> over set-gadget-delegate
33 dup dup set-control-self
34 [ editor-doc-end ] keep ;
37 { T{ key-down f f "UP" } [ find-search-list select-prev ] }
38 { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
39 { T{ key-down f f "RETURN" } [ find-search-list list-action ] }
42 : <search-model> ( producer -- model )
43 gadget get live-search-field control-model 200 <delay>
44 [ "\n" join ] <filter>
47 : <search-list> ( seq producer presenter -- gadget )
48 -rot curry <search-model>
49 [ find-workspace hide-popup ] -rot
52 C: live-search ( string seq producer presenter -- gadget )
67 [ live-search-field set-editor-string ] keep
68 [ live-search-field editor-doc-end ] keep ;
70 M: live-search focusable-child* live-search-field ;
72 : <word-search> ( string words -- gadget )
77 : help-completions ( str pairs -- seq )
79 [ second >lower ] swap completions
80 [ first <link> ] map ;
82 : <help-search> ( string -- gadget )
83 all-articles [ dup article-title 2array ] map sort-values
88 : <source-file-search> ( string files -- gadget )
89 [ string-completions [ <pathname> ] map ]
93 : module-completions ( str modules -- seq )
94 [ module-name ] swap completions ;
96 : <module-search> ( string -- gadget )
97 available-modules [ module-completions ]
101 : <vocab-search> ( string -- gadget )
102 vocabs [ string-completions [ <vocab-link> ] map ]
106 : <history-search> ( string seq -- gadget )
107 [ string-completions [ <input> ] map ]
111 : workspace-listener ( workspace -- listener )
112 listener-gadget swap find-tool tool-gadget nip ;
114 : current-word ( workspace -- string )
115 workspace-listener listener-gadget-input selected-word ;
117 : show-word-search ( workspace words -- )
118 >r dup current-word r> <word-search>
119 "Word search" show-titled-popup ;
121 : show-vocab-words ( workspace vocab -- )
122 "" over words natural-sort <word-search>
123 "Words in " rot append show-titled-popup ;
125 : show-help-search ( workspace -- )
126 "" <help-search> "Help search" show-titled-popup ;
128 : all-source-files ( -- seq )
129 source-files get hash-keys natural-sort ;
131 : show-source-file-search ( workspace -- )
132 "" all-source-files <source-file-search>
133 "Source file search" show-titled-popup ;
135 : show-module-files ( workspace module -- )
136 "" over module-files* <source-file-search>
137 "Source files in " rot module-name append show-titled-popup ;
139 : show-vocab-search ( workspace -- )
140 dup current-word <vocab-search>
141 "Vocabulary search" show-titled-popup ;
143 : show-module-search ( workspace -- )
144 "" <module-search> "Module search" show-titled-popup ;
146 : listener-history ( listener -- seq )
147 listener-gadget-input interactor-history <reversed> ;
149 : show-history ( workspace -- )
150 "" over workspace-listener listener-history <history-search>
151 "History search" show-titled-popup ;
153 workspace "toolbar" {
156 T{ key-down f { C+ } "p" }
161 T{ key-down f f "TAB" }
162 [ all-words show-word-search ]
166 T{ key-down f { C+ } "u" }
167 [ show-vocab-search ]
171 T{ key-down f { C+ } "m" }
172 [ show-module-search ]
176 T{ key-down f { C+ } "e" }
177 [ show-source-file-search ]
181 T{ key-down f { C+ } "h" }