basis/tools/completion/completion.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs colors.constants combinators
   4 combinators.short-circuit fry io.directories io.files
   5 io.files.info io.pathnames kernel locals make math math.order
   6 sequences sequences.private sorting splitting typed
   7 unicode.categories unicode.data vectors vocabs vocabs.hierarchy
   8 ;
   9
  10 IN: tools.completion
  11
  12 <PRIVATE
  13
  14 : smart-index-from ( obj i seq -- n/f )
  15     rot [ ch>lower ] [ ch>upper ] bi
  16     '[ dup _ eq? [ drop t ] [ _ eq? ] if ] find-from drop ;
  17
  18 :: (fuzzy) ( accum i full ch -- accum i ? )
  19     ch i full smart-index-from [
  20         [ accum push ]
  21         [ accum swap 1 + t ] bi
  22     ] [
  23         f -1 f
  24     ] if* ; inline
  25
  26 PRIVATE>
  27
  28 : fuzzy ( full short -- indices )
  29     dup [ length <vector> 0 ] curry 2dip
  30     [ (fuzzy) ] with all? 2drop ;
  31
  32 <PRIVATE
  33
  34 : (runs) ( runs n seq -- runs n )
  35     [
  36         [
  37             2dup number=
  38             [ drop ] [ nip V{ } clone pick push ] if
  39             1 +
  40         ] keep pick last push
  41     ] each ; inline
  42
  43 PRIVATE>
  44
  45 : runs ( seq -- newseq )
  46     [ V{ } clone 1vector ] dip [ first ] keep (runs) drop ;
  47
  48 <PRIVATE
  49
  50 : score-1 ( i full -- n )
  51     {
  52         { [ over zero? ] [ 2drop 10 ] }
  53         { [ 2dup length 1 - number= ] [ 2drop 4 ] }
  54         { [ 2dup [ 1 - ] dip nth-unsafe Letter? not ] [ 2drop 10 ] }
  55         { [ 2dup [ 1 + ] dip nth-unsafe Letter? not ] [ 2drop 4 ] }
  56         [ 2drop 1 ]
  57     } cond ; inline
  58
  59 PRIVATE>
  60
  61 : score ( full fuzzy -- n )
  62     dup [
  63         [ [ length ] bi@ - 15 swap [-] 3 /f ] 2keep
  64         runs [
  65             [ 0 [ pick score-1 max ] reduce nip ] keep
  66             length * +
  67         ] with each
  68     ] [
  69         2drop 0
  70     ] if ;
  71
  72 : rank-completions ( results -- newresults )
  73     sort-keys <reversed>
  74     [ 0 [ first max ] reduce 3 /f ] keep
  75     [ first-unsafe < ] with filter
  76     values ;
  77
  78 : complete ( full short -- score )
  79     [ dupd fuzzy score ] 2keep
  80     [ <reversed> ] bi@
  81     dupd fuzzy score max ;
  82
  83 : completion ( short candidate -- result )
  84     [ second swap complete ] keep 2array ; inline
  85
  86 : completion, ( short candidate -- )
  87     completion dup first-unsafe 0 > [ , ] [ drop ] if ;
  88
  89 : completions ( short candidates -- seq )
  90     [ ] [
  91         [ [ completion, ] with each ] { } make
  92         rank-completions
  93     ] bi-curry if-empty ;
  94
  95 : name-completions ( str seq -- seq' )
  96     [ dup name>> ] { } map>assoc completions ;
  97
  98 : words-matching ( str -- seq )
  99     all-words name-completions ;
 100
 101 : vocabs-matching ( str -- seq )
 102     all-disk-vocabs-recursive filter-vocabs name-completions ;
 103
 104 : chars-matching ( str -- seq )
 105     name-map keys dup zip completions ;
 106
 107 : colors-matching ( str -- seq )
 108     named-colors dup zip completions ;
 109
 110 : strings-matching ( str seq -- seq' )
 111     dup zip completions keys ;
 112
 113 <PRIVATE
 114
 115 : directory-paths ( directory -- alist )
 116     dup '[
 117         [
 118             [ dup _ prepend-path ]
 119             [ file-info directory? [ path-separator append ] when ]
 120             bi swap
 121         ] { } map>assoc
 122     ] with-directory-files ;
 123
 124 PRIVATE>
 125
 126 : paths-matching ( str -- seq )
 127     dup last-path-separator [ 1 + cut ] [ drop "" ] if swap
 128     dup { [ exists? ] [ file-info directory? ] } 1&&
 129     [ directory-paths completions ] [ 2drop { } ] if ;
 130
 131 <PRIVATE
 132
 133 : (complete-single-vocab?) ( str -- ? )
 134     { "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" }
 135     member? ; inline
 136
 137 : complete-single-vocab? ( tokens -- ? )
 138     dup last empty? [
 139         harvest ?last (complete-single-vocab?)
 140     ] [
 141         harvest dup length 1 >
 142         [ 2 tail* ?first (complete-single-vocab?) ] [ drop f ] if
 143     ] if ;
 144
 145 : chop-; ( seq -- seq' )
 146     { ";" } split1-last [ ] [ ] ?if ;
 147
 148 : complete-vocab-list? ( tokens -- ? )
 149     chop-; 1 short head* "USING:" swap member? ;
 150
 151 PRIVATE>
 152
 153 : complete-vocab? ( tokens -- ? )
 154     { [ complete-single-vocab? ] [ complete-vocab-list? ] } 1|| ;
 155
 156 <PRIVATE
 157
 158 : complete-token? ( tokens token -- ? )
 159     over last empty? [
 160         [ harvest ?last ] [ = ] bi*
 161     ] [
 162         swap harvest dup length 1 >
 163         [ 2 tail* ?first = ] [ 2drop f ] if
 164     ] if ; inline
 165
 166 PRIVATE>
 167
 168 : complete-char? ( tokens -- ? ) "CHAR:" complete-token? ;
 169
 170 : complete-color? ( tokens -- ? ) "COLOR:" complete-token? ;
 171
 172 : complete-pathname? ( tokens -- ? ) "P\"" complete-token? ;