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