basis/listener/listener.factor

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