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     current-vocab name>> auto-use? get [ " - auto" append ] when
  16     "( " " )" surround ;
  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 : trimmed-stack. ( seq -- )
  97     dup length max-stack-items get > [
  98         max-stack-items get cut*
  99         [
 100             [ length number>string "(" " more items)" surround ] keep
 101             write-object nl
 102         ] dip
 103     ] when stack. ;
 104
 105 : datastack. ( datastack -- )
 106     display-stacks? get [
 107         [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
 108     ] [ drop ] if ;
 109
 110 :: (listener) ( datastack -- )
 111     parser-quiet? off
 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) ;
 131
 132 PRIVATE>
 133
 134 SYMBOL: interactive-vocabs
 135
 136 {
 137     "accessors"
 138     "arrays"
 139     "assocs"
 140     "combinators"
 141     "compiler.errors"
 142     "compiler.units"
 143     "continuations"
 144     "debugger"
 145     "definitions"
 146     "editors"
 147     "help"
 148     "help.apropos"
 149     "help.lint"
 150     "help.vocabs"
 151     "inspector"
 152     "io"
 153     "io.files"
 154     "io.pathnames"
 155     "kernel"
 156     "listener"
 157     "math"
 158     "math.order"
 159     "memory"
 160     "namespaces"
 161     "parser"
 162     "prettyprint"
 163     "see"
 164     "sequences"
 165     "slicing"
 166     "sorting"
 167     "stack-checker"
 168     "strings"
 169     "syntax"
 170     "tools.annotations"
 171     "tools.crossref"
 172     "tools.deprecation"
 173     "tools.destructors"
 174     "tools.disassembler"
 175     "tools.dispatch"
 176     "tools.errors"
 177     "tools.memory"
 178     "tools.profiler"
 179     "tools.test"
 180     "tools.threads"
 181     "tools.time"
 182     "tools.walker"
 183     "vocabs"
 184     "vocabs.loader"
 185     "vocabs.refresh"
 186     "vocabs.hierarchy"
 187     "words"
 188     "scratchpad"
 189 } interactive-vocabs set-global
 190
 191 : only-use-vocabs ( vocabs -- )
 192     clear-manifest
 193     [ vocab ] filter
 194     [
 195         vocab
 196         [ find-vocab-root not ]
 197         [ source-loaded?>> +done+ eq? ] bi or
 198     ] filter
 199     [ use-vocab ] each ;
 200
 201 : with-interactive-vocabs ( quot -- )
 202     [
 203         "scratchpad" set-current-vocab
 204         interactive-vocabs get only-use-vocabs
 205         call
 206     ] with-manifest ; inline
 207
 208 : listener ( -- )
 209     [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
 210
 211 MAIN: listener