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