extra/readline-listener/readline-listener.factor

   1 ! Copyright (C) 2011 Erik Charlebois.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors assocs colors combinators io kernel listener
   5 readline sequences sets splitting threads tools.completion
   6 unicode.data vocabs vocabs.hierarchy ;
   7
   8 IN: readline-listener
   9
  10 <PRIVATE
  11
  12 SYMBOL: completions
  13
  14 TUPLE: readline-reader { prompt initial: f } ;
  15 INSTANCE: readline-reader input-stream
  16
  17 M: readline-reader stream-readln
  18     flush
  19     [ dup [ " " append ] when readline f ] change-prompt
  20     drop ;
  21
  22 M: readline-reader prompt.
  23     >>prompt drop ;
  24
  25 : clear-completions ( -- )
  26     f completions tset ;
  27
  28 : prefixed ( prefix seq -- seq' )
  29     swap '[ _ head? ] filter ;
  30
  31 : prefixed-words ( prefix -- words )
  32     all-words [ name>> ] map! prefixed members ;
  33
  34 : prefixed-vocabs ( prefix -- vocabs )
  35     all-disk-vocabs-recursive filter-vocabs [ name>> ] map! prefixed ;
  36
  37 : prefixed-vocab-words ( prefix vocab-name -- words )
  38     vocab-words [ name>> ] map! prefixed ;
  39
  40 : prefixed-colors ( prefix -- colors )
  41     named-colors prefixed ;
  42
  43 : prefixed-chars ( prefix -- chars )
  44     name-map keys prefixed ;
  45
  46 : prefixed-paths ( prefix -- paths )
  47     dup paths-matching keys prefixed ;
  48
  49 : get-completions ( prefix -- completions )
  50     completions tget [ nip ] [
  51         completion-line " \r\n" split {
  52             { [ dup complete-vocab? ] [ drop prefixed-vocabs ] }
  53             { [ dup complete-char? ] [ drop prefixed-chars ] }
  54             { [ dup complete-color? ] [ drop prefixed-colors ] }
  55             { [ dup complete-pathname? ] [ drop prefixed-paths ] }
  56             { [ dup complete-vocab-words? ] [ harvest second prefixed-vocab-words ] }
  57             [ drop prefixed-words ]
  58         } cond dup completions tset
  59     ] if* ;
  60
  61 PRIVATE>
  62
  63 : readline-listener ( -- )
  64     [
  65         swap get-completions ?nth
  66         [ clear-completions f ] unless*
  67     ] set-completion
  68     readline-reader new [ listener-main ] with-input-stream* ;
  69
  70 : ?readline-listener ( -- )
  71     has-readline? [ readline-listener ] [ listener ] if ;
  72
  73 MAIN: readline-listener