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 prettyprint fry
   7 sets vocabs.parser ;
   8 IN: listener
   9
  10 GENERIC: stream-read-quot ( stream -- quot/f )
  11
  12 : parse-lines-interactive ( lines -- quot/f )
  13     [ parse-lines in get ] with-compilation-unit in set ;
  14
  15 : read-quot-step ( lines -- quot/f )
  16     [ parse-lines-interactive ] [
  17         dup error>> unexpected-eof?
  18         [ 2drop f ] [ rethrow ] if
  19     ] recover ;
  20
  21 : read-quot-loop  ( stream accum -- quot/f )
  22     over stream-readln dup [
  23         over push
  24         dup read-quot-step dup
  25         [ 2nip ] [ drop read-quot-loop ] if
  26     ] [
  27         3drop f
  28     ] if ;
  29
  30 M: object stream-read-quot
  31     V{ } clone read-quot-loop ;
  32
  33 : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
  34
  35 <PRIVATE
  36
  37 SYMBOL: quit-flag
  38
  39 PRIVATE>
  40
  41 : bye ( -- ) quit-flag on ;
  42
  43 SYMBOL: visible-vars
  44
  45 : show-var ( var -- ) visible-vars  [ swap suffix ] change ;
  46
  47 : show-vars ( seq -- ) visible-vars [ swap union ] change ;
  48
  49 : hide-var ( var -- ) visible-vars [ remove ] change ;
  50
  51 : hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
  52
  53 : hide-all-vars ( -- ) visible-vars off ;
  54
  55 SYMBOL: error-hook
  56
  57 [ print-error-and-restarts ] error-hook set-global
  58
  59 <PRIVATE
  60
  61 : title. ( string -- )
  62     H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
  63
  64 : visible-vars. ( -- )
  65     visible-vars get [
  66         nl "--- Watched variables:" title.
  67         standard-table-style [
  68             [
  69                 [
  70                     [ [ short. ] with-cell ]
  71                     [ [ get short. ] with-cell ]
  72                     bi
  73                 ] with-row
  74             ] each
  75         ] tabular-output
  76     ] unless-empty ;
  77
  78 SYMBOL: display-stacks?
  79
  80 t display-stacks? set-global
  81
  82 : stacks. ( -- )
  83     display-stacks? get [
  84         datastack [ nl "--- Data stack:" title. stack. ] unless-empty
  85     ] when ;
  86
  87 : prompt. ( -- )
  88     "( " in get auto-use? get [ " - auto" append ] when " )" 3append
  89     H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
  90
  91 : listen ( -- )
  92     visible-vars. stacks. prompt.
  93     [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
  94     [
  95         dup lexer-error? [
  96             error-hook get call
  97         ] [
  98             rethrow
  99         ] if
 100     ] recover ;
 101
 102 : until-quit ( -- )
 103     quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
 104
 105 PRIVATE>
 106
 107 : listener ( -- )
 108     [ until-quit ] with-interactive-vocabs ;
 109
 110 MAIN: listener