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