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