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 GENERIC# prompt. 1 ( stream prompt -- )
  12
  13 : prompt ( -- str )
  14     current-vocab name>> auto-use? get [ " - auto" append ] when
  15     "( " " )" surround ;
  16
  17 M: object prompt.
  18     nip H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl
  19     flush ;
  20
  21 : parse-lines-interactive ( lines -- quot/f )
  22     [ parse-lines ] with-compilation-unit ;
  23
  24 : read-quot-step ( lines -- quot/f )
  25     [ parse-lines-interactive ] [
  26         dup error>> unexpected-eof?
  27         [ 2drop f ] [ rethrow ] if
  28     ] recover ;
  29
  30 : read-quot-loop ( stream accum -- quot/f )
  31     over stream-readln dup [
  32         over push
  33         dup read-quot-step dup
  34         [ 2nip ] [ drop read-quot-loop ] if
  35     ] [
  36         3drop f
  37     ] if ;
  38
  39 M: object stream-read-quot
  40     V{ } clone read-quot-loop ;
  41
  42 : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
  43
  44 SYMBOL: visible-vars
  45
  46 : show-var ( var -- ) visible-vars [ swap suffix ] change ;
  47
  48 : show-vars ( seq -- ) visible-vars [ swap union ] change ;
  49
  50 : hide-var ( var -- ) visible-vars [ remove ] change ;
  51
  52 : hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
  53
  54 : hide-all-vars ( -- ) visible-vars off ;
  55
  56 SYMBOL: error-hook
  57
  58 : call-error-hook ( error -- )
  59     error-continuation get error-hook get
  60     call( continuation error -- ) ;
  61
  62 [ drop print-error-and-restarts ] error-hook set-global
  63
  64 SYMBOL: display-stacks?
  65
  66 t display-stacks? set-global
  67
  68 SYMBOL: max-stack-items
  69
  70 10 max-stack-items set-global
  71
  72 SYMBOL: error-summary?
  73
  74 t error-summary? set-global
  75
  76 <PRIVATE
  77
  78 : title. ( string -- )
  79     H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
  80
  81 : visible-vars. ( -- )
  82     visible-vars get [
  83         nl "--- Watched variables:" title.
  84         standard-table-style [
  85             [
  86                 [
  87                     [ [ short. ] with-cell ]
  88                     [ [ get short. ] with-cell ]
  89                     bi
  90                 ] with-row
  91             ] each
  92         ] tabular-output nl
  93     ] unless-empty ;
  94
  95 : trimmed-stack. ( seq -- )
  96     dup length max-stack-items get > [
  97         max-stack-items get cut*
  98         [
  99             [ length number>string "(" " more items)" surround ] keep
 100             write-object nl
 101         ] dip
 102     ] when stack. ;
 103
 104 : datastack. ( datastack -- )
 105     display-stacks? get [
 106         [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
 107     ] [ drop ] if ;
 108
 109 :: (listener) ( datastack -- )
 110     error-summary? get [ error-summary ] when
 111     visible-vars.
 112     datastack datastack.
 113     input-stream get prompt prompt.
 114
 115     [
 116         read-quot [
 117             '[ datastack _ with-datastack ]
 118             [ call-error-hook datastack ]
 119             recover
 120         ] [ return ] if*
 121     ] [
 122         dup lexer-error?
 123         [ call-error-hook datastack ]
 124         [ rethrow ]
 125         if
 126     ] recover
 127
 128     (listener) ;
 129
 130 PRIVATE>
 131
 132 SYMBOL: interactive-vocabs
 133
 134 {
 135     "accessors"
 136     "arrays"
 137     "assocs"
 138     "combinators"
 139     "compiler.errors"
 140     "compiler.units"
 141     "continuations"
 142     "debugger"
 143     "definitions"
 144     "editors"
 145     "help"
 146     "help.apropos"
 147     "help.lint"
 148     "help.vocabs"
 149     "inspector"
 150     "io"
 151     "io.files"
 152     "io.pathnames"
 153     "kernel"
 154     "listener"
 155     "math"
 156     "math.order"
 157     "memory"
 158     "namespaces"
 159     "parser"
 160     "prettyprint"
 161     "see"
 162     "sequences"
 163     "slicing"
 164     "sorting"
 165     "stack-checker"
 166     "strings"
 167     "syntax"
 168     "tools.annotations"
 169     "tools.crossref"
 170     "tools.deprecation"
 171     "tools.destructors"
 172     "tools.disassembler"
 173     "tools.dispatch"
 174     "tools.errors"
 175     "tools.memory"
 176     "tools.profiler"
 177     "tools.test"
 178     "tools.threads"
 179     "tools.time"
 180     "tools.walker"
 181     "vocabs"
 182     "vocabs.loader"
 183     "vocabs.refresh"
 184     "vocabs.hierarchy"
 185     "words"
 186     "scratchpad"
 187 } interactive-vocabs set-global
 188
 189 : only-use-vocabs ( vocabs -- )
 190     clear-manifest
 191     [ vocab ] filter
 192     [
 193         vocab
 194         [ find-vocab-root not ]
 195         [ source-loaded?>> +done+ eq? ] bi or
 196     ] filter
 197     [ use-vocab ] each ;
 198
 199 : with-interactive-vocabs ( quot -- )
 200     [
 201         "scratchpad" set-current-vocab
 202         interactive-vocabs get only-use-vocabs
 203         call
 204     ] with-manifest ; inline
 205
 206 : listener ( -- )
 207     [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
 208
 209 MAIN: listener