basis/help/search/search.factor

   1 ! Copyright (C) 2012 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: arrays assocs combinators combinators.short-circuit fry
   5 help help.apropos help.markup help.stylesheet help.topics io
   6 io.streams.string io.styles kernel math memoize namespaces
   7 sequences sequences.deep sorting splitting strings unicode
   8 words ;
   9
  10 IN: help.search
  11
  12 <PRIVATE
  13
  14 : search-words ( str -- seq )
  15     >lower "-" split [ [ blank? ] split-when ] map concat ;
  16
  17 : element-value ( element -- str )
  18     dup array? [
  19         dup ?first {
  20             { \ $link [ second article-name ] }
  21             { \ $vocab-link [ second ] }
  22             { \ $emphasis [ second ] }
  23             { \ $subsection [ second article-name ] }
  24             { \ $subsections [ rest [ article-name ] map " " join ] }
  25             { \ $description [ rest [ element-value ] map " " join ] }
  26             { \ $notes [ rest [ element-value ] map " " join ] }
  27             { \ $snippet [ rest [ element-value ] map " " join ] }
  28             [ 2drop f ]
  29         } case
  30     ] [ dup string? [ drop f ] unless ] if ;
  31
  32 MEMO: article-words ( name -- words )
  33     article-content [ element-value ] map " " join search-words
  34     [ [ digit? ] all? ] reject
  35     [ [ { [ letter? ] [ digit? ] } 1|| not ] trim ] map! harvest  ;
  36
  37 : (search-articles) ( string -- seq' )
  38     search-words [ { } ] [
  39         [ all-articles ] dip
  40         dup length 1 > [
  41             '[ article-words _ swap subseq? ] filter
  42         ] [
  43             first '[ article-words [ _ head? ] any? ] filter
  44         ] if
  45     ] if-empty [ article-name ] sort-with ;
  46
  47 PRIVATE>
  48
  49 : search-articles ( string -- )
  50     [
  51         last-element off
  52         [
  53             "Search results for “" "”" surround
  54             title-style get [ format ] ($block)
  55         ]
  56         [
  57             (search-articles) [ word? ] partition swap
  58             "Articles" "Words"
  59             [ over empty? [ 2drop ] [ $heading $completions ] if ]
  60             bi-curry@ bi*
  61         ] bi
  62     ] with-default-style nl ;