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