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.apropos tools.crossref classes.tuple
   7 vocabs words vocabs.loader tools.vocabs unicode.case calendar
   8 locals fry ui.tools.interactor ui.tools.listener
   9 ui.tools.workspace ui.commands ui.gadgets ui.gadgets.editors
  10 ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
  11 ui.gadgets.borders 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     [
  59         [ limited-completions ] [ completions ] ?
  60         '[ _ @ [ first ] map ] <search-model>
  61     ] 3bi
  62     >>model ; inline
  63
  64 : <search-list> ( presenter live-search -- list )
  65     [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
  66
  67 :: <live-search> ( string seq limited? presenter -- gadget )
  68     { 0 1 } live-search new-track
  69         <search-field> >>field
  70         seq limited? init-search-model
  71         presenter over <search-list> >>list
  72         dup field>> 1 <border> { 1 1 } >>fill f track-add
  73         dup list>> <scroller> 1 track-add
  74         string over field>> set-editor-string
  75         dup field>> end-of-document ;
  76
  77 M: live-search focusable-child* field>> ;
  78
  79 M: live-search pref-dim* drop { 400 200 } ;
  80
  81 : current-word ( workspace -- string )
  82     listener>> input>> selected-word ;
  83
  84 : definition-candidates ( words -- candidates )
  85     [ dup synopsis >lower ] { } map>assoc sort-values ;
  86
  87 : <definition-search> ( string words limited? -- gadget )
  88     [ definition-candidates ] dip [ synopsis ] <live-search> ;
  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-search> ( string -- gadget )
 108     all-articles help-candidates
 109     f [ article-title ] <live-search> ;
 110
 111 : com-search ( workspace -- )
 112     "" <help-search> "Help search" show-titled-popup ;
 113
 114 : source-file-candidates ( seq -- candidates )
 115     [ dup <pathname> swap >lower ] { } map>assoc ;
 116
 117 : <source-file-search> ( string files -- gadget )
 118     source-file-candidates
 119     f [ string>> ] <live-search> ;
 120
 121 : all-source-files ( -- seq )
 122     source-files get keys natural-sort ;
 123
 124 : com-sources ( workspace -- )
 125     "" all-source-files <source-file-search>
 126     "Source file search" show-titled-popup ;
 127
 128 : show-vocab-files ( workspace vocab -- )
 129     [ "" swap vocab-files <source-file-search> ]
 130     [ "Source files in " swap vocab-name append ]
 131     bi show-titled-popup ;
 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     [ [ <input> ] [ >lower ] bi ] { } map>assoc ;
 142
 143 : <history-search> ( string seq -- gadget )
 144     history-candidates
 145     f [ string>> ] <live-search> ;
 146
 147 : listener-history ( listener -- seq )
 148     input>> history>> <reversed> ;
 149
 150 : com-history ( workspace -- )
 151     "" over 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