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 help help.topics io.pathnames io.styles
   4 kernel models models.delay models.filter namespaces prettyprint
   5 quotations sequences sorting source-files definitions strings
   6 tools.completion tools.crossref classes.tuple vocabs words
   7 vocabs.loader tools.vocabs unicode.case calendar locals
   8 ui.tools.interactor ui.tools.listener ui.tools.workspace
   9 ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
  10 ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
  11 ui.gestures ui.operations ui ;
  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         [ search-value ] dip 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 -- filter )
  51     [
  52         field>> model>>
  53         ui-running? [ 1/5 seconds <delay> ] when
  54     ] dip [ "\n" join ] prepend <filter> ;
  55
  56 : init-search-model ( live-search seq limited? -- live-search )
  57     [ 2drop ]
  58     [ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
  59     >>model ; inline
  60
  61 : <search-list> ( presenter live-search -- list )
  62     [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
  63
  64 :: <live-search> ( string seq limited? presenter -- gadget )
  65     { 0 1 } live-search new-track
  66         <search-field> >>field
  67         seq limited? init-search-model
  68         presenter over <search-list> >>list
  69         dup field>> 1 <border> { 1 1 } >>fill f track-add
  70         dup list>> <scroller> 1 track-add
  71         string over field>> set-editor-string
  72         dup field>> end-of-document ;
  73
  74 M: live-search focusable-child* field>> ;
  75
  76 M: live-search pref-dim* drop { 400 200 } ;
  77
  78 : current-word ( workspace -- string )
  79     listener>> input>> selected-word ;
  80
  81 : definition-candidates ( words -- candidates )
  82     [ dup synopsis >lower ] { } map>assoc sort-values ;
  83
  84 : <definition-search> ( string words limited? -- gadget )
  85     [ definition-candidates ] dip [ synopsis ] <live-search> ;
  86
  87 : word-candidates ( words -- candidates )
  88     [ dup name>> >lower ] { } map>assoc ;
  89
  90 : <word-search> ( string words limited? -- gadget )
  91     [ word-candidates ] dip [ synopsis ] <live-search> ;
  92
  93 : com-words ( workspace -- )
  94     dup current-word all-words t <word-search>
  95     "Word search" show-titled-popup ;
  96
  97 : show-vocab-words ( workspace vocab -- )
  98     [ "" swap words natural-sort f <word-search> ]
  99     [ "Words in " swap vocab-name append ]
 100     bi show-titled-popup ;
 101
 102 : show-word-usage ( workspace word -- )
 103     [ "" swap smart-usage f <definition-search> ]
 104     [ "Words and methods using " swap name>> append ]
 105     bi show-titled-popup ;
 106
 107 : help-candidates ( seq -- candidates )
 108     [ dup >link swap article-title >lower ] { } map>assoc
 109     sort-values ;
 110
 111 : <help-search> ( string -- gadget )
 112     all-articles help-candidates
 113     f [ article-title ] <live-search> ;
 114
 115 : com-search ( workspace -- )
 116     "" <help-search> "Help search" show-titled-popup ;
 117
 118 : source-file-candidates ( seq -- candidates )
 119     [ dup <pathname> swap >lower ] { } map>assoc ;
 120
 121 : <source-file-search> ( string files -- gadget )
 122     source-file-candidates
 123     f [ string>> ] <live-search> ;
 124
 125 : all-source-files ( -- seq )
 126     source-files get keys natural-sort ;
 127
 128 : com-sources ( workspace -- )
 129     "" all-source-files <source-file-search>
 130     "Source file search" show-titled-popup ;
 131
 132 : show-vocab-files ( workspace vocab -- )
 133     [ "" swap vocab-files <source-file-search> ]
 134     [ "Source files in " swap vocab-name append ]
 135     bi show-titled-popup ;
 136
 137 : vocab-candidates ( -- candidates )
 138     all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
 139
 140 : <vocab-search> ( string -- gadget )
 141     vocab-candidates f [ vocab-name ] <live-search> ;
 142
 143 : com-vocabs ( workspace -- )
 144     dup current-word <vocab-search>
 145     "Vocabulary search" show-titled-popup ;
 146
 147 : history-candidates ( seq -- candidates )
 148     [ dup <input> swap >lower ] { } map>assoc ;
 149
 150 : <history-search> ( string seq -- gadget )
 151     history-candidates
 152     f [ string>> ] <live-search> ;
 153
 154 : listener-history ( listener -- seq )
 155     input>> history>> <reversed> ;
 156
 157 : com-history ( workspace -- )
 158     "" over listener>> listener-history <history-search>
 159     "History search" show-titled-popup ;
 160
 161 workspace "toolbar" f {
 162     { T{ key-down f { C+ } "p" } com-history }
 163     { T{ key-down f f "TAB" } com-words }
 164     { T{ key-down f { C+ } "u" } com-vocabs }
 165     { T{ key-down f { C+ } "e" } com-sources }
 166     { T{ key-down f { C+ } "h" } com-search }
 167 } define-command-map