extra/readline-listener/readline-listener.factor

   1 ! Copyright (C) 2011 Erik Charlebois.
   2 ! See http://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 : get-completions ( prefix -- completions )
  47     completions tget [ nip ] [
  48         completion-line " \r\n" split {
  49             { [ dup complete-vocab? ] [ drop prefixed-vocabs ] }
  50             { [ dup complete-char? ] [ drop prefixed-chars ] }
  51             { [ dup complete-color? ] [ drop prefixed-colors ] }
  52             { [ dup complete-vocab-words? ] [ harvest second prefixed-vocab-words ] }
  53             [ drop prefixed-words ]
  54         } cond dup completions tset
  55     ] if* ;
  56
  57 PRIVATE>
  58
  59 : readline-listener ( -- )
  60     [
  61         swap get-completions ?nth
  62         [ clear-completions f ] unless*
  63     ] set-completion
  64     readline-reader new [ listener-main ] with-input-stream* ;
  65
  66 : ?readline-listener ( -- )
  67     has-readline? [ readline-listener ] [ listener ] if ;
  68
  69 MAIN: readline-listener