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