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: accessors 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 ( gadget -- search )
  31     [ [ live-search? ] is? ] find-parent ;
  32
  33 : find-search-list ( gadget -- list )
  34     find-live-search live-search-list ;
  35
  36 TUPLE: search-field ;
  37
  38 : <search-field> ( -- gadget )
  39     <editor> search-field construct-editor ;
  40
  41 search-field H{
  42     { T{ key-down f f "UP" } [ find-search-list select-previous ] }
  43     { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
  44     { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
  45     { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
  46     { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
  47 } set-gestures
  48
  49 : <search-model> ( producer -- model )
  50     >r g live-search-field gadget-model
  51     ui-running? [ 1/5 seconds <delay> ] when
  52     [ "\n" join ] r> append <filter> ;
  53
  54 : <search-list> ( seq limited? presenter -- gadget )
  55     >r
  56     [ limited-completions ] [ completions ] ? curry
  57     <search-model>
  58     >r [ find-workspace hide-popup ] r> r>
  59     swap <list> ;
  60
  61 : <live-search> ( string seq limited? presenter -- gadget )
  62     live-search new
  63     [
  64         <search-field> g-> set-live-search-field f track,
  65         <search-list> g-> set-live-search-list
  66         <scroller> 1 track,
  67     ] { 0 1 } build-track
  68     [ live-search-field set-editor-string ] keep
  69     [ live-search-field end-of-document ] keep ;
  70
  71 M: live-search focusable-child* live-search-field ;
  72
  73 M: live-search pref-dim* drop { 400 200 } ;
  74
  75 : current-word ( workspace -- string )
  76     workspace-listener listener-gadget-input selected-word ;
  77
  78 : definition-candidates ( words -- candidates )
  79     [ dup synopsis >lower ] { } map>assoc sort-values ;
  80
  81 : <definition-search> ( string words limited? -- gadget )
  82     >r definition-candidates r> [ synopsis ] <live-search> ;
  83
  84 : word-candidates ( words -- candidates )
  85     [ dup name>> >lower ] { } map>assoc ;
  86
  87 : <word-search> ( string words limited? -- gadget )
  88     >r word-candidates r> [ synopsis ] <live-search> ;
  89
  90 : com-words ( workspace -- )
  91     dup current-word all-words t <word-search>
  92     "Word search" show-titled-popup ;
  93
  94 : show-vocab-words ( workspace vocab -- )
  95     "" over words natural-sort f <word-search>
  96     "Words in " rot vocab-name append show-titled-popup ;
  97
  98 : show-word-usage ( workspace word -- )
  99     "" over smart-usage f <definition-search>
 100     "Words and methods using " rot name>> append
 101     show-titled-popup ;
 102
 103 : help-candidates ( seq -- candidates )
 104     [ dup >link swap article-title >lower ] { } map>assoc
 105     sort-values ;
 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 [ pathname-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     "" over vocab-files <source-file-search>
 130     "Source files in " rot vocab-name append show-titled-popup ;
 131
 132 : vocab-candidates ( -- candidates )
 133     all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
 134
 135 : <vocab-search> ( string -- gadget )
 136     vocab-candidates f [ vocab-name ] <live-search> ;
 137
 138 : com-vocabs ( workspace -- )
 139     dup current-word <vocab-search>
 140     "Vocabulary search" show-titled-popup ;
 141
 142 : history-candidates ( seq -- candidates )
 143     [ dup <input> swap >lower ] { } map>assoc ;
 144
 145 : <history-search> ( string seq -- gadget )
 146     history-candidates
 147     f [ input-string ] <live-search> ;
 148
 149 : listener-history ( listener -- seq )
 150     listener-gadget-input interactor-history <reversed> ;
 151
 152 : com-history ( workspace -- )
 153     "" over workspace-listener listener-history <history-search>
 154     "History search" show-titled-popup ;
 155
 156 workspace "toolbar" f {
 157     { T{ key-down f { C+ } "p" } com-history }
 158     { T{ key-down f f "TAB" } com-words }
 159     { T{ key-down f { C+ } "u" } com-vocabs }
 160     { T{ key-down f { C+ } "e" } com-sources }
 161     { T{ key-down f { C+ } "h" } com-search }
 162 } define-command-map