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