library/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-frames gadgets-labels
   5 gadgets-panes gadgets-scrolling gadgets-text gadgets-theme
   6 generic help tools kernel models sequences words
   7 gadgets-borders gadgets-lists namespaces parser hashtables io
   8 completion styles ;
   9
  10 TUPLE: live-search field list producer action presenter ;
  11
  12 : find-live-search [ live-search? ] find-parent ;
  13
  14 : find-search-list find-live-search live-search-list ;
  15
  16 TUPLE: search-field ;
  17
  18 C: search-field ( string -- gadget )
  19     <editor> over set-gadget-delegate
  20     dup dup set-control-self
  21     [ set-editor-text ] keep
  22     [ select-all ] keep ;
  23
  24 search-field H{
  25     { T{ key-down f f "UP" } [ find-search-list select-prev ] }
  26     { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
  27     { T{ key-down f f "RETURN" } [ find-search-list call-action ] }
  28 } set-gestures
  29
  30 : <search-model> ( -- model )
  31     gadget get dup live-search-field control-model
  32     swap live-search-producer [ "\n" join ] swap append
  33     <filter> ;
  34
  35 : <search-list>
  36     <search-model>
  37     gadget get live-search-presenter [ make-pane ] curry
  38     gadget get live-search-action \ first add*
  39     <list> ;
  40
  41 C: live-search ( string action producer presenter -- gadget )
  42     [ set-live-search-presenter ] keep
  43     [ set-live-search-producer ] keep
  44     [ set-live-search-action ] keep
  45     {
  46         {
  47             [ <search-field> ]
  48             set-live-search-field
  49             f
  50             @top
  51         }
  52         {
  53             [ <search-list> ]
  54             set-live-search-list
  55             [ <scroller> ]
  56             @center
  57         }
  58     } make-frame* ;
  59
  60 M: live-search focusable-child* live-search-field ;
  61
  62 : <word-search> ( string action -- gadget )
  63     all-words
  64     [ word-completions ] curry
  65     [ word-completion. ]
  66     <live-search> "Word search" <labelled-gadget> ;
  67
  68 : <help-search> ( string action -- gadget )
  69     [ search-help ]
  70     [ first ($link) ]
  71     <live-search> "Help search" <labelled-gadget> ;
  72
  73 : string-completion. ( pair quot -- )
  74     >r first2 over completion>string swap r> call write-object ;
  75     inline
  76
  77 : <source-files-search> ( string action -- gadget )
  78     source-files get hash-keys natural-sort
  79     [ string-completions ] curry
  80     [ [ <pathname> ] string-completion. ]
  81     <live-search> "Source file search" <labelled-gadget> ;
  82
  83 : <vocabs-search> ( string action -- gadget )
  84     vocabs
  85     [ string-completions ] curry
  86     [ [ <vocab-link> ] string-completion. ]
  87     <live-search> "Vocabulary search" <labelled-gadget> ;