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 combinators
   4 combinators.short-circuit io.directories io.files io.files.info
   5 io.pathnames kernel make math math.order sequences
   6 sequences.private sorting splitting splitting.monotonic unicode
   7 unicode.data vocabs vocabs.hierarchy ;
   8 IN: tools.completion
   9
  10 <PRIVATE
  11
  12 : fuzzy-index-from ( ch i seq -- n/f )
  13     rot [ ch>lower ] [ ch>upper ] bi
  14     '[ dup _ eq? [ drop t ] [ _ eq? ] if ] find-from drop ;
  15
  16 :: (fuzzy) ( accum i ch full -- accum i ? )
  17     ch i full fuzzy-index-from [
  18         [ accum push ]
  19         [ accum swap 1 + t ] bi
  20     ] [
  21         f f f
  22     ] if* ; inline
  23
  24 PRIVATE>
  25
  26 : fuzzy ( full short -- indices )
  27     [ V{ } clone 0 ] 2dip swap '[ _ (fuzzy) ] all? 2drop ;
  28
  29 : runs ( seq -- newseq )
  30     [ 1 - = ] monotonic-split-slice ;
  31
  32 <PRIVATE
  33
  34 : score-1 ( i full -- n )
  35     {
  36         { [ over zero? ] [ 2drop 10 ] }
  37         { [ 2dup length 1 - = ] [ 2drop 4 ] }
  38         { [ 2dup [ 1 - ] dip nth-unsafe Letter? not ] [ 2drop 10 ] }
  39         { [ 2dup [ 1 + ] dip nth-unsafe Letter? not ] [ 2drop 4 ] }
  40         [ 2drop 1 ]
  41     } cond ; inline
  42
  43 PRIVATE>
  44
  45 : score ( full fuzzy -- n )
  46     [
  47         [ [ length ] bi@ - 15 swap [-] 3 /f ] 2keep
  48         runs [
  49             [ 0 [ pick score-1 max ] reduce nip ] keep
  50             length * +
  51         ] with each
  52     ] [
  53         drop 0
  54     ] if* ;
  55
  56 : rank-completions ( results -- newresults )
  57     dup length 25 > [
  58         [ [ first ] [ max ] map-reduce 4 /f ] keep
  59         [ first < ] with filter
  60     ] when sort-keys <reversed> values ;
  61
  62 : complete ( full short -- score )
  63     [ dupd fuzzy score ] 2keep pick 0 > [
  64         [ <reversed> ] bi@ dupd fuzzy score max
  65     ] [ 2drop ] if ;
  66
  67 : completion ( short candidate -- score candidate )
  68     [ second swap complete ] keep ; inline
  69
  70 : completion, ( short candidate -- )
  71     completion over 0 > [ 2array , ] [ 2drop ] 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         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 over qualified-named [ append ] unless-empty completions ;
  98
  99 : chars-matching ( str -- seq )
 100     name-map keys dup zip completions ;
 101
 102 : colors-matching ( str -- seq )
 103     named-colors dup zip completions ;
 104
 105 : strings-matching ( str seq -- seq' )
 106     dup zip completions keys ;
 107
 108 <PRIVATE
 109
 110 : directory-paths ( directory -- alist )
 111     dup '[
 112         [
 113             [ name>> dup _ prepend-path ]
 114             [ directory? [ path-separator append ] when ]
 115             bi swap
 116         ] { } map>assoc
 117     ] with-directory-entries ;
 118
 119 PRIVATE>
 120
 121 : paths-matching ( str -- seq )
 122     "P\"" ?head [
 123         dup last-path-separator [ 1 + cut ] [ drop "" ] if swap
 124         dup { [ file-exists? ] [ file-info directory? ] } 1&&
 125         [ directory-paths completions ] [ 2drop { } ] if
 126     ] dip [ [ [ "P\"" prepend ] dip ] assoc-map ] when ;
 127
 128 <PRIVATE
 129
 130 : (complete-single-vocab?) ( str -- ? )
 131     {
 132         "IN:" "USE:" "UNUSE:" "QUALIFIED:"
 133         "QUALIFIED-WITH:" "FROM:" "EXCLUDE:"
 134         "REUSE:"
 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 cramp head* "USING:" swap member? ;
 150
 151 PRIVATE>
 152
 153 : complete-vocab? ( tokens -- ? )
 154     { [ complete-single-vocab? ] [ complete-vocab-list? ] } 1|| ;
 155
 156 : complete-vocab-words? ( tokens -- ? )
 157     harvest chop-; {
 158         [ length 3 >= ]
 159         [ first { "FROM:" "EXCLUDE:" } member? ]
 160         [ third "=>" = ]
 161     } 1&& ;
 162
 163 <PRIVATE
 164
 165 : complete-token? ( tokens token -- ? )
 166     over last empty? [
 167         [ harvest ?last ] [ = ] bi*
 168     ] [
 169         swap harvest dup length 1 >
 170         [ 2 tail* ?first = ] [ 2drop f ] if
 171     ] if ; inline
 172
 173 PRIVATE>
 174
 175 : complete-char? ( tokens -- ? ) "CHAR:" complete-token? ;
 176
 177 : complete-color? ( tokens -- ? ) "COLOR:" complete-token? ;
 178
 179 <PRIVATE
 180
 181 : complete-string? ( tokens token -- ? )
 182     {
 183         [
 184             [ harvest ?last ] dip ?head
 185             [ ?last CHAR: \" = not ] [ drop f ] if
 186         ]
 187         [ complete-token? ]
 188     } 2|| ;
 189
 190 PRIVATE>
 191
 192 : complete-pathname? ( tokens -- ? ) "P\"" complete-string? ;