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 vocabs vocabs.loader ;
   8 IN: listener
   9
  10 GENERIC: stream-read-quot ( stream -- quot/f )
  11
  12 : parse-lines-interactive ( lines -- quot/f )
  13     [ parse-lines ] with-compilation-unit ;
  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( continuation error -- ) ;
  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     current-vocab name>> 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 SYMBOL: interactive-vocabs
 128
 129 {
 130     "accessors"
 131     "arrays"
 132     "assocs"
 133     "combinators"
 134     "compiler.errors"
 135     "compiler.units"
 136     "continuations"
 137     "debugger"
 138     "definitions"
 139     "editors"
 140     "help"
 141     "help.apropos"
 142     "help.lint"
 143     "help.vocabs"
 144     "inspector"
 145     "io"
 146     "io.files"
 147     "io.pathnames"
 148     "kernel"
 149     "listener"
 150     "math"
 151     "math.order"
 152     "memory"
 153     "namespaces"
 154     "parser"
 155     "prettyprint"
 156     "see"
 157     "sequences"
 158     "slicing"
 159     "sorting"
 160     "stack-checker"
 161     "strings"
 162     "syntax"
 163     "tools.annotations"
 164     "tools.crossref"
 165     "tools.deprecation"
 166     "tools.destructors"
 167     "tools.disassembler"
 168     "tools.dispatch"
 169     "tools.errors"
 170     "tools.memory"
 171     "tools.profiler"
 172     "tools.test"
 173     "tools.threads"
 174     "tools.time"
 175     "tools.walker"
 176     "vocabs"
 177     "vocabs.loader"
 178     "vocabs.refresh"
 179     "vocabs.hierarchy"
 180     "words"
 181     "scratchpad"
 182 } interactive-vocabs set-global
 183
 184 : only-use-vocabs ( vocabs -- )
 185     clear-manifest
 186     [ vocab ] filter
 187     [
 188         vocab
 189         [ find-vocab-root not ]
 190         [ source-loaded?>> +done+ eq? ] bi or
 191     ] filter
 192     [ use-vocab ] each ;
 193
 194 : with-interactive-vocabs ( quot -- )
 195     [
 196         "scratchpad" set-current-vocab
 197         interactive-vocabs get only-use-vocabs
 198         call
 199     ] with-manifest ; inline
 200
 201 : listener ( -- )
 202     [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
 203
 204 MAIN: listener