basis/ui/tools/search/search.factor

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