basis/tools/apropos/apropos.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs fry help.markup help.topics io
   4 kernel make math math.parser namespaces sequences sorting
   5 summary tools.completion tools.vocabs tools.vocabs.browser
   6 vocabs words unicode.case help ;
   7 IN: tools.apropos
   8
   9 : $completions ( seq -- )
  10     dup [ word? ] all? [ words-table ] [
  11         dup [ vocab-spec? ] all? [
  12             $vocabs
  13         ] [
  14             [ <$pretty-link> 1array ] map $table
  15         ] if
  16     ] if ;
  17
  18 TUPLE: more-completions seq ;
  19
  20 CONSTANT: max-completions 5
  21
  22 M: more-completions article-title
  23     seq>> length number>string " results" append ;
  24
  25 M: more-completions article-name
  26     seq>> length max-completions - number>string " more results" append ;
  27
  28 M: more-completions article-content
  29     seq>> sort-values keys \ $completions prefix ;
  30
  31 : (apropos) ( str candidates title -- element )
  32     [
  33         [ completions ] dip '[
  34             _ 1array \ $heading prefix ,
  35             [ max-completions short head keys \ $completions prefix , ]
  36             [ dup length max-completions > [ more-completions boa <$link> , ] [ drop ] if ]
  37             bi
  38         ] unless-empty
  39     ] { } make ;
  40
  41 : word-candidates ( words -- candidates )
  42     [ dup name>> >lower ] { } map>assoc ;
  43
  44 : vocab-candidates ( -- candidates )
  45     all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
  46
  47 : help-candidates ( seq -- candidates )
  48     [ [ >link ] [ article-title >lower ] bi ] { } map>assoc
  49     sort-values ;
  50
  51 : $apropos ( str -- )
  52     first
  53     [ all-words word-candidates "Words" (apropos) ]
  54     [ vocab-candidates "Vocabularies" (apropos) ]
  55     [ articles get keys help-candidates "Help articles" (apropos) ]
  56     tri 3array print-element ;
  57
  58 TUPLE: apropos search ;
  59
  60 C: <apropos> apropos
  61
  62 M: apropos article-title
  63     search>> "Search results for “" "”" surround ;
  64
  65 M: apropos article-name article-title ;
  66
  67 M: apropos article-content
  68     search>> 1array \ $apropos prefix ;
  69
  70 : apropos ( str -- )
  71     <apropos> print-topic ;