core/ui/tools/search.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-search
   4 USING: arrays gadgets gadgets-labels gadgets-panes
   5 gadgets-scrolling gadgets-text gadgets-theme
   6 generic help tools kernel models sequences words
   7 gadgets-borders gadgets-lists gadgets-workspace gadgets-listener
   8 namespaces parser hashtables io completion styles strings
   9 modules prettyprint ;
  10
  11 TUPLE: live-search field list ;
  12
  13 : search-gesture ( gesture live-search -- command/f )
  14     live-search-list list-value object-operations
  15     [ command-gesture = ] find-with nip ;
  16
  17 M: live-search handle-gesture* ( gadget gesture delegate -- ? )
  18     drop over search-gesture dup [
  19         over find-workspace hide-popup
  20         >r live-search-list list-value r> invoke-command f
  21     ] [
  22         2drop t
  23     ] if ;
  24
  25 : find-live-search [ [ live-search? ] is? ] find-parent ;
  26
  27 : find-search-list find-live-search live-search-list ;
  28
  29 TUPLE: search-field ;
  30
  31 C: search-field ( -- gadget )
  32     <editor> over set-gadget-delegate
  33     dup dup set-control-self
  34     [ editor-doc-end ] keep ;
  35
  36 search-field H{
  37     { T{ key-down f f "UP" } [ find-search-list select-prev ] }
  38     { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
  39     { T{ key-down f f "RETURN" } [ find-search-list list-action ] }
  40 } set-gestures
  41
  42 : <search-model> ( producer -- model )
  43     gadget get live-search-field control-model 200 <delay>
  44     [ "\n" join ] <filter>
  45     swap <filter> ;
  46
  47 : <search-list> ( seq producer presenter -- gadget )
  48     -rot curry <search-model>
  49     [ find-workspace hide-popup ] -rot
  50     <list> ;
  51
  52 C: live-search ( string seq producer presenter -- gadget )
  53     {
  54         {
  55             [ <search-field> ]
  56             set-live-search-field
  57             f
  58             @top
  59         }
  60         {
  61             [ <search-list> ]
  62             set-live-search-list
  63             [ <scroller> ]
  64             @center
  65         }
  66     } make-frame*
  67     [ live-search-field set-editor-string ] keep
  68     [ live-search-field editor-doc-end ] keep ;
  69
  70 M: live-search focusable-child* live-search-field ;
  71
  72 : <word-search> ( string words -- gadget )
  73     [ word-completions ]
  74     [ summary ]
  75     <live-search> ;
  76
  77 : help-completions ( str pairs -- seq )
  78     >r >lower r>
  79     [ second >lower ] swap completions
  80     [ first <link> ] map ;
  81
  82 : <help-search> ( string -- gadget )
  83     all-articles [ dup article-title 2array ] map sort-values
  84     [ help-completions ]
  85     [ article-title ]
  86     <live-search> ;
  87
  88 : <source-file-search> ( string files -- gadget )
  89     [ string-completions [ <pathname> ] map ]
  90     [ pathname-string ]
  91     <live-search> ;
  92
  93 : module-completions ( str modules -- seq )
  94     [ module-name ] swap completions ;
  95
  96 : <module-search> ( string -- gadget )
  97     available-modules [ module-completions ]
  98     [ module-string ]
  99     <live-search> ;
 100
 101 : <vocab-search> ( string -- gadget )
 102     vocabs [ string-completions [ <vocab-link> ] map ]
 103     [ vocab-link-name ]
 104     <live-search> ;
 105
 106 : <history-search> ( string seq -- gadget )
 107     [ string-completions [ <input> ] map ]
 108     [ input-string ]
 109     <live-search> ;
 110
 111 : workspace-listener ( workspace -- listener )
 112     listener-gadget swap find-tool tool-gadget nip ;
 113
 114 : current-word ( workspace -- string )
 115     workspace-listener listener-gadget-input selected-word ;
 116
 117 : show-word-search ( workspace words -- )
 118     >r dup current-word r> <word-search>
 119     "Word search" show-titled-popup ;
 120
 121 : show-vocab-words ( workspace vocab -- )
 122     "" over words natural-sort <word-search>
 123     "Words in " rot append show-titled-popup ;
 124
 125 : show-help-search ( workspace -- )
 126     "" <help-search> "Help search" show-titled-popup ;
 127
 128 : all-source-files ( -- seq )
 129     source-files get hash-keys natural-sort ;
 130
 131 : show-source-file-search ( workspace -- )
 132     "" all-source-files <source-file-search>
 133     "Source file search" show-titled-popup ;
 134
 135 : show-module-files ( workspace module -- )
 136     "" over module-files* <source-file-search>
 137     "Source files in " rot module-name append show-titled-popup ;
 138
 139 : show-vocab-search ( workspace -- )
 140     dup current-word <vocab-search>
 141     "Vocabulary search" show-titled-popup ;
 142
 143 : show-module-search ( workspace -- )
 144     "" <module-search> "Module search" show-titled-popup ;
 145
 146 : listener-history ( listener -- seq )
 147     listener-gadget-input interactor-history <reversed> ;
 148
 149 : show-history ( workspace -- )
 150     "" over workspace-listener listener-history <history-search>
 151     "History search" show-titled-popup ;
 152
 153 workspace "toolbar" {
 154     {
 155         "History"
 156         T{ key-down f { C+ } "p" }
 157         [ show-history ]
 158     }
 159     {
 160         "Words"
 161         T{ key-down f f "TAB" }
 162         [ all-words show-word-search ]
 163     }
 164     {
 165         "Vocabularies"
 166         T{ key-down f { C+ } "u" }
 167         [ show-vocab-search ]
 168     }
 169     {
 170         "Modules"
 171         T{ key-down f { C+ } "m" }
 172         [ show-module-search ]
 173     }
 174     {
 175         "Sources"
 176         T{ key-down f { C+ } "e" }
 177         [ show-source-file-search ]
 178     }
 179     {
 180         "Search help"
 181         T{ key-down f { C+ } "h" }
 182         [ show-help-search ]
 183     }
 184 } define-commands