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