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