basis/listener/listener.factor

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