basis/listener/listener.factor

   1 ! Copyright (C) 2003, 2009 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 source-files.errors locals ;
   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 SYMBOL: visible-vars
  36
  37 : show-var ( var -- ) visible-vars [ swap suffix ] change ;
  38
  39 : show-vars ( seq -- ) visible-vars [ swap union ] change ;
  40
  41 : hide-var ( var -- ) visible-vars [ remove ] change ;
  42
  43 : hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
  44
  45 : hide-all-vars ( -- ) visible-vars off ;
  46
  47 SYMBOL: error-hook
  48
  49 : call-error-hook ( error -- )
  50     error-continuation get error-hook get
  51     call( error continuation -- ) ;
  52
  53 [ drop print-error-and-restarts ] error-hook set-global
  54
  55 SYMBOL: display-stacks?
  56
  57 t display-stacks? set-global
  58
  59 SYMBOL: max-stack-items
  60
  61 10 max-stack-items set-global
  62
  63 SYMBOL: error-summary?
  64
  65 t error-summary? set-global
  66
  67 <PRIVATE
  68
  69 : title. ( string -- )
  70     H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
  71
  72 : visible-vars. ( -- )
  73     visible-vars get [
  74         nl "--- Watched variables:" title.
  75         standard-table-style [
  76             [
  77                 [
  78                     [ [ short. ] with-cell ]
  79                     [ [ get short. ] with-cell ]
  80                     bi
  81                 ] with-row
  82             ] each
  83         ] tabular-output nl
  84     ] unless-empty ;
  85
  86 : trimmed-stack. ( seq -- )
  87     dup length max-stack-items get > [
  88         max-stack-items get cut*
  89         [
  90             [ length number>string "(" " more items)" surround ] keep
  91             write-object nl
  92         ] dip
  93     ] when stack. ;
  94
  95 : datastack. ( datastack -- )
  96     display-stacks? get [
  97         [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
  98     ] [ drop ] if ;
  99
 100 : prompt. ( -- )
 101     in get auto-use? get [ " - auto" append ] when "( " " )" surround
 102     H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
 103
 104 :: (listener) ( datastack -- )
 105     error-summary? get [ error-summary ] when
 106     visible-vars.
 107     datastack datastack.
 108     prompt.
 109
 110     [
 111         read-quot [
 112             '[ datastack _ with-datastack ]
 113             [ call-error-hook datastack ]
 114             recover
 115         ] [ return ] if*
 116     ] [
 117         dup lexer-error?
 118         [ call-error-hook datastack ]
 119         [ rethrow ]
 120         if
 121     ] recover
 122
 123     (listener) ;
 124
 125 PRIVATE>
 126
 127 : listener ( -- )
 128     [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
 129
 130 MAIN: listener