extra/ui/tools/search/search.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs ui.tools.interactor ui.tools.listener
   4 ui.tools.workspace help help.topics io.files io.styles kernel
   5 models namespaces prettyprint quotations sequences sorting
   6 source-files definitions strings tools.completion tools.crossref
   7 classes.tuple ui.commands ui.gadgets ui.gadgets.editors
   8 ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
   9 ui.gestures ui.operations vocabs words vocabs.loader
  10 tools.vocabs unicode.case calendar ui ;
  11 IN: ui.tools.search
  12
  13 TUPLE: live-search field list ;
  14
  15 : search-value ( live-search -- value )
  16     live-search-list list-value ;
  17
  18 : search-gesture ( gesture live-search -- operation/f )
  19     search-value object-operations
  20     [ operation-gesture = ] with find nip ;
  21
  22 M: live-search handle-gesture* ( gadget gesture delegate -- ? )
  23     drop over search-gesture dup [
  24         over find-workspace hide-popup
  25         >r search-value r> invoke-command f
  26     ] [
  27         2drop t
  28     ] if ;
  29
  30 : find-live-search [ [ live-search? ] is? ] find-parent ;
  31
  32 : find-search-list find-live-search live-search-list ;
  33
  34 TUPLE: search-field ;
  35
  36 : <search-field> ( -- gadget )
  37     <editor> search-field construct-editor ;
  38
  39 search-field H{
  40     { T{ key-down f f "UP" } [ find-search-list select-previous ] }
  41     { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
  42     { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
  43     { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
  44     { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
  45 } set-gestures
  46
  47 : <search-model> ( producer -- model )
  48     >r g live-search-field gadget-model
  49     ui-running? [ 1/5 seconds <delay> ] when
  50     [ "\n" join ] r> append <filter> ;
  51
  52 : <search-list> ( seq limited? presenter -- gadget )
  53     >r
  54     [ limited-completions ] [ completions ] ? curry
  55     <search-model>
  56     >r [ find-workspace hide-popup ] r> r>
  57     swap <list> ;
  58
  59 : <live-search> ( string seq limited? presenter -- gadget )
  60     live-search new
  61     [
  62         <search-field> g-> set-live-search-field f track,
  63         <search-list> g-> set-live-search-list
  64         <scroller> 1 track,
  65     ] { 0 1 } build-track
  66     [ live-search-field set-editor-string ] keep
  67     [ live-search-field end-of-document ] keep ;
  68
  69 M: live-search focusable-child* live-search-field ;
  70
  71 M: live-search pref-dim* drop { 400 200 } ;
  72
  73 : current-word ( workspace -- string )
  74     workspace-listener listener-gadget-input selected-word ;
  75
  76 : definition-candidates ( words -- candidates )
  77     [ dup synopsis >lower ] { } map>assoc sort-values ;
  78
  79 : <definition-search> ( string words limited? -- gadget )
  80     >r definition-candidates r> [ synopsis ] <live-search> ;
  81
  82 : word-candidates ( words -- candidates )
  83     [ dup word-name >lower ] { } map>assoc ;
  84
  85 : <word-search> ( string words limited? -- gadget )
  86     >r word-candidates r> [ synopsis ] <live-search> ;
  87
  88 : com-words ( workspace -- )
  89     dup current-word all-words t <word-search>
  90     "Word search" show-titled-popup ;
  91
  92 : show-vocab-words ( workspace vocab -- )
  93     "" over words natural-sort f <word-search>
  94     "Words in " rot vocab-name append show-titled-popup ;
  95
  96 : show-word-usage ( workspace word -- )
  97     "" over smart-usage f <definition-search>
  98     "Words and methods using " rot word-name append
  99     show-titled-popup ;
 100
 101 : help-candidates ( seq -- candidates )
 102     [ dup >link swap article-title >lower ] { } map>assoc
 103     sort-values ;
 104
 105 : <help-search> ( string -- gadget )
 106     all-articles help-candidates
 107     f [ article-title ] <live-search> ;
 108
 109 : com-search ( workspace -- )
 110     "" <help-search> "Help search" show-titled-popup ;
 111
 112 : source-file-candidates ( seq -- candidates )
 113     [ dup <pathname> swap >lower ] { } map>assoc ;
 114
 115 : <source-file-search> ( string files -- gadget )
 116     source-file-candidates
 117     f [ pathname-string ] <live-search> ;
 118
 119 : all-source-files ( -- seq )
 120     source-files get keys natural-sort ;
 121
 122 : com-sources ( workspace -- )
 123     "" all-source-files <source-file-search>
 124     "Source file search" show-titled-popup ;
 125
 126 : show-vocab-files ( workspace vocab -- )
 127     "" over vocab-files <source-file-search>
 128     "Source files in " rot vocab-name append show-titled-popup ;
 129
 130 : vocab-candidates ( -- candidates )
 131     all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
 132
 133 : <vocab-search> ( string -- gadget )
 134     vocab-candidates f [ vocab-name ] <live-search> ;
 135
 136 : com-vocabs ( workspace -- )
 137     dup current-word <vocab-search>
 138     "Vocabulary search" show-titled-popup ;
 139
 140 : history-candidates ( seq -- candidates )
 141     [ dup <input> swap >lower ] { } map>assoc ;
 142
 143 : <history-search> ( string seq -- gadget )
 144     history-candidates
 145     f [ input-string ] <live-search> ;
 146
 147 : listener-history ( listener -- seq )
 148     listener-gadget-input interactor-history <reversed> ;
 149
 150 : com-history ( workspace -- )
 151     "" over workspace-listener listener-history <history-search>
 152     "History search" show-titled-popup ;
 153
 154 workspace "toolbar" f {
 155     { T{ key-down f { C+ } "p" } com-history }
 156     { T{ key-down f f "TAB" } com-words }
 157     { T{ key-down f { C+ } "u" } com-vocabs }
 158     { T{ key-down f { C+ } "e" } com-sources }
 159     { T{ key-down f { C+ } "h" } com-search }
 160 } define-command-map