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