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) ( datastack -- )
 112     parser-quiet? off
 113     error-summary? get [ error-summary ] when
 114     visible-vars.
 115     datastack datastack.
 116     input-stream get prompt prompt.
 117
 118     [
 119         read-quot [
 120             '[ datastack _ with-datastack ]
 121             [ call-error-hook datastack ]
 122             recover
 123         ] [ return ] if*
 124     ] [
 125         dup lexer-error?
 126         [ call-error-hook datastack ]
 127         [ rethrow ]
 128         if
 129     ] recover
 130
 131     (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     [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
 213
 214 : listener-main ( -- )
 215     version-info print flush listener ;
 216
 217 MAIN: listener-main