basis/listener/listener.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays hashtables io kernel math math.parser memory
   4 namespaces parser lexer sequences strings io.styles
   5 vectors words generic system combinators continuations debugger
   6 definitions compiler.units accessors colors ;
   7
   8 IN: listener
   9
  10 SYMBOL: quit-flag
  11
  12 SYMBOL: listener-hook
  13
  14 [ ] listener-hook set-global
  15
  16 GENERIC: stream-read-quot ( stream -- quot/f )
  17
  18 : parse-lines-interactive ( lines -- quot/f )
  19     [ parse-lines in get ] with-compilation-unit in set ;
  20
  21 : read-quot-step ( lines -- quot/f )
  22     [ parse-lines-interactive ] [
  23         dup error>> unexpected-eof?
  24         [ 2drop f ] [ rethrow ] if
  25     ] recover ;
  26
  27 : read-quot-loop  ( stream accum -- quot/f )
  28     over stream-readln dup [
  29         over push
  30         dup read-quot-step dup
  31         [ 2nip ] [ drop read-quot-loop ] if
  32     ] [
  33         3drop f
  34     ] if ;
  35
  36 M: object stream-read-quot
  37     V{ } clone read-quot-loop ;
  38
  39 : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
  40
  41 : bye ( -- ) quit-flag on ;
  42
  43 : prompt. ( -- )
  44     "( " in get " )" 3append
  45     H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
  46
  47 SYMBOL: error-hook
  48
  49 [ print-error-and-restarts ] error-hook set-global
  50
  51 : listen ( -- )
  52     listener-hook get call prompt.
  53     [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
  54     [
  55         dup lexer-error? [
  56             error-hook get call
  57         ] [
  58             rethrow
  59         ] if
  60     ] recover ;
  61
  62 : until-quit ( -- )
  63     quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
  64
  65 : listener ( -- )
  66     [ until-quit ] with-interactive-vocabs ;
  67
  68 MAIN: listener