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