basis/help/apropos/apropos.factor

   1 ! Copyright (C) 2008, 2010 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 vocabs.hierarchy help.vocabs
   6 vocabs words unicode.case help unicode.categories
   7 combinators locals ;
   8 IN: help.apropos
   9
  10 : $completions ( seq -- )
  11     dup [ word? ] all? [ words-table ] [
  12         dup [ vocab-spec? ] all? [
  13             $vocabs
  14         ] [
  15             [ <$pretty-link> 1array ] map $table
  16         ] if
  17     ] if ;
  18
  19 SYMBOLS: word-result vocabulary-result article-result ;
  20
  21 : category>title ( category -- name )
  22     {
  23         { word-result [ "Words" ] }
  24         { vocabulary-result [ "Vocabularies" ] }
  25         { article-result [ "Help articles" ] }
  26     } case ;
  27
  28 : category>name ( category -- name )
  29     {
  30         { word-result [ "word" ] }
  31         { vocabulary-result [ "vocabulary" ] }
  32         { article-result [ "help article" ] }
  33     } case ;
  34
  35 TUPLE: more-completions seq search category ;
  36
  37 CONSTANT: max-completions 5
  38
  39 M: more-completions valid-article? drop t ;
  40
  41 M: more-completions article-title
  42     [
  43         "All " %
  44         [ seq>> length # " " % ]
  45         [ category>> category>name % ]
  46         [ " results for “" % search>> % "”" % ] tri
  47     ] "" make ;
  48
  49 M: more-completions article-content
  50     seq>> [ second >lower ] sort-with keys \ $completions prefix ;
  51
  52 :: (apropos) ( search completions category -- element )
  53     completions [
  54         [
  55             { $heading search } ,
  56             [ max-completions short head keys \ $completions prefix , ]
  57             [
  58                 length max-completions >
  59                 [ { $link T{ more-completions f completions search category } } , ] when
  60             ] bi
  61         ] unless-empty
  62     ] { } make ;
  63
  64 : articles-matching ( str -- seq )
  65     articles get
  66     [ [ >link ] [ title>> ] bi* ] { } assoc-map-as
  67     completions ;
  68
  69 : $apropos ( str -- )
  70     first
  71     [ dup words-matching word-result (apropos) ]
  72     [ dup vocabs-matching vocabulary-result (apropos) ]
  73     [ dup articles-matching article-result (apropos) ]
  74     tri 3array print-element ;
  75
  76 TUPLE: apropos-search text ;
  77
  78 C: <apropos-search> apropos-search
  79
  80 M: apropos-search valid-article? drop t ;
  81
  82 M: apropos-search article-title
  83     text>> "Search results for “" "”" surround ;
  84
  85 M: apropos-search article-content
  86     text>> 1array \ $apropos prefix ;
  87
  88 M: apropos-search >link ;
  89
  90 INSTANCE: apropos-search topic
  91
  92 : apropos ( str -- )
  93     [ blank? ] trim <apropos-search> print-topic ;