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 3 /f ] keep
  60     [ first-unsafe < ] with filter
  61     sort-keys <reversed> values ;
  62
  63 : complete ( full short -- score )
  64     2dup [ <reversed> ] bi@ [ dupd fuzzy score ] 2bi@ max ;
  65
  66 : completion ( short candidate -- result )
  67     [ second swap complete ] keep 2array ; inline
  68
  69 : completion, ( short candidate -- )
  70     completion dup first-unsafe 0 > [ , ] [ drop ] if ;
  71
  72 : completions ( short candidates -- seq )
  73     [ ] [
  74         [ [ completion, ] with each ] { } make
  75         rank-completions
  76     ] bi-curry if-empty ;
  77
  78 : name-completions ( str seq -- seq' )
  79     [ dup name>> ] { } map>assoc completions ;
  80
  81 : words-matching ( str -- seq )
  82     all-words name-completions ;
  83
  84 : vocabs-matching ( str -- seq )
  85     all-disk-vocabs-recursive filter-vocabs name-completions ;
  86
  87 : chars-matching ( str -- seq )
  88     name-map keys dup zip completions ;
  89
  90 : colors-matching ( str -- seq )
  91     named-colors dup zip completions ;
  92
  93 : strings-matching ( str seq -- seq' )
  94     dup zip completions keys ;
  95
  96 <PRIVATE
  97
  98 : directory-paths ( directory -- alist )
  99     dup '[
 100         [
 101             [ name>> dup _ prepend-path ]
 102             [ directory? [ path-separator append ] when ]
 103             bi swap
 104         ] { } map>assoc
 105     ] with-directory-entries ;
 106
 107 PRIVATE>
 108
 109 : paths-matching ( str -- seq )
 110     dup last-path-separator [ 1 + cut ] [ drop "" ] if swap
 111     dup { [ exists? ] [ file-info directory? ] } 1&&
 112     [ directory-paths completions ] [ 2drop { } ] if ;
 113
 114 <PRIVATE
 115
 116 : (complete-single-vocab?) ( str -- ? )
 117     { "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" }
 118     member? ; inline
 119
 120 : complete-single-vocab? ( tokens -- ? )
 121     dup last empty? [
 122         harvest ?last (complete-single-vocab?)
 123     ] [
 124         harvest dup length 1 >
 125         [ 2 tail* ?first (complete-single-vocab?) ] [ drop f ] if
 126     ] if ;
 127
 128 : chop-; ( seq -- seq' )
 129     { ";" } split1-last [ ] [ ] ?if ;
 130
 131 : complete-vocab-list? ( tokens -- ? )
 132     chop-; 1 short head* "USING:" swap member? ;
 133
 134 PRIVATE>
 135
 136 : complete-vocab? ( tokens -- ? )
 137     { [ complete-single-vocab? ] [ complete-vocab-list? ] } 1|| ;
 138
 139 <PRIVATE
 140
 141 : complete-token? ( tokens token -- ? )
 142     over last empty? [
 143         [ harvest ?last ] [ = ] bi*
 144     ] [
 145         swap harvest dup length 1 >
 146         [ 2 tail* ?first = ] [ 2drop f ] if
 147     ] if ; inline
 148
 149 PRIVATE>
 150
 151 : complete-char? ( tokens -- ? ) "CHAR:" complete-token? ;
 152
 153 : complete-color? ( tokens -- ? ) "COLOR:" complete-token? ;
 154
 155 : complete-pathname? ( tokens -- ? ) "P\"" complete-token? ;