Live search command handling improved

TODO.FACTOR.txt

@@ -1,7 +1,5 @@
 + 0.87:
 
-- module operations on module-links, etc
-- empty search list, handle
 - variable width word wrap
 - graphical crossref tool
 - http://paste.lisp.org/display/30426

library/generic/tuple.factor

@@ -92,7 +92,7 @@ M: tuple equal?
     over tuple? [ tuple= ] [ 2drop f ] if ;
 
 : (delegates) ( obj -- )
-    [ dup delegate (delegates) , ] when* ;
+    [ dup , delegate (delegates) ] when* ;
 
 : delegates ( obj -- seq ) [ (delegates) ] { } make ;
 

library/generic/tuple.facts

@@ -62,7 +62,7 @@ HELP: define-tuple
 
 HELP: delegates
 { $values { "obj" "an object" } { "seq" "a sequence" } }
-{ $description "Outputs the delegation chain of an object. The last element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
+{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
 
 HELP: is?
 { $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }

library/ui/tools/operations.factor

@@ -318,28 +318,3 @@ link class-operations [ help-action ] modify-commands
 [ command-name "Follow" = not ] subset
 append
 define-commands
-
-\ word-search "operations"
-{ word compound } [ class-operations ] map concat
-[ search-action ] modify-commands
-define-commands
-
-\ vocab-search "operations"
-\ vocab-link class-operations
-[ search-action ] modify-commands
-define-commands
-
-\ module-search "operations"
-\ module class-operations
-[ search-action ] modify-commands
-define-commands
-
-\ source-file-search "operations"
-\ pathname class-operations
-[ search-action ] modify-commands
-define-commands
-
-\ help-search "operations"
-\ link class-operations
-[ search-action ] modify-commands
-define-commands

library/ui/tools/search.factor

@@ -10,6 +10,18 @@ modules prettyprint ;
 
 TUPLE: live-search field list ;
 
+: search-gesture ( gesture live-search -- command/f )
+    live-search-list list-value object-operations
+    [ command-gesture = ] find-with nip ;
+
+M: live-search handle-gesture* ( gadget gesture delegate -- ? )
+    drop over search-gesture dup [
+        over find-workspace hide-popup
+        >r live-search-list list-value r> invoke-command f
+    ] [
+        2drop t
+    ] if ;
+
 : find-live-search [ [ live-search? ] is? ] find-parent ;
 
 : find-search-list find-live-search live-search-list ;
@@ -61,73 +73,45 @@ M: live-search focusable-child* live-search-field ;
 : delegate>live-search ( string seq producer presenter gadget -- )
     >r <live-search> r> set-gadget-delegate ;
 
-TUPLE: word-search ;
+: <word-search> ( string words -- gadget )
-
-C: word-search ( string words -- gadget )
-    >r
     [ word-completions ]
     [ summary ]
-    r>
+    <live-search> ;
-    [ delegate>live-search ] keep ;
 
 : help-completions ( str pairs -- seq )
     >r >lower r>
     [ second >lower ] swap completions
     [ first <link> ] map ;
 
-TUPLE: help-search ;
+: <help-search> ( string -- gadget )
-
-C: help-search ( string -- gadget )
-    >r
     all-articles [ dup article-title 2array ] map
     [ [ second ] 2apply <=> ] sort
     [ help-completions ]
     [ article-title ]
-    r>
+    <live-search> ;
-    [ delegate>live-search ] keep ;
 
-TUPLE: source-file-search ;
+: <source-file-search> ( string files -- gadget )
-
-C: source-file-search ( string files -- gadget )
-    >r
     [ string-completions [ <pathname> ] map ]
     [ pathname-string ]
-    r>
+    <live-search> ;
-    [ delegate>live-search ] keep ;
 
 : module-completions ( str modules -- seq )
     [ module-name ] swap completions ;
 
-TUPLE: module-search ;
+: <module-search> ( string -- gadget )
-
-C: module-search ( string -- gadget )
-    >r
     available-modules [ module-completions ]
     [ module-string ]
-    r>
+    <live-search> ;
-    [ delegate>live-search ] keep ;
 
-TUPLE: vocab-search ;
+: <vocab-search> ( string -- gadget )
-
-C: vocab-search ( string -- gadget )
-    >r
     vocabs [ string-completions [ <vocab-link> ] map ]
     [ vocab-link-name ]
-    r>
+    <live-search> ;
-    [ delegate>live-search ] keep ;
 
-TUPLE: history-search ;
+: <history-search> ( string seq -- gadget )
-
-C: history-search ( string seq -- gadget )
-    >r
     [ string-completions [ <input> ] map ]
     [ input-string ]
-    r>
+    <live-search> ;
-    [ delegate>live-search ] keep ;
-
-: search-action ( search -- obj )
-    dup find-workspace hide-popup
-    live-search-list list-value ;
 
 : show-titled-popup ( workspace gadget title -- )
     [ find-workspace hide-popup ] <closable-gadget>