ui.theme: updates to color scheme.

[factor.git] / basis / listener / listener.factor

diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 4563f61ab79a146f08bf20a6d5a5dd6bcf0af38e..5099c5ab905299966e028a2132c7c4a2a3edf44e 100644 (file)
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -1,13 +1,28 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel math math.parser memory
-namespaces parser lexer sequences strings io.styles
-vectors words generic system combinators continuations debugger
-definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser source-files.errors locals ;
+USING: accessors colors colors.constants
+combinators.short-circuit compiler.units continuations debugger
+fry io io.styles kernel lexer literals locals math math.parser
+namespaces parser parser.notes prettyprint sequences sets
+source-files.errors system vocabs vocabs.loader
+vocabs.parser ;
 IN: listener
 
 GENERIC: stream-read-quot ( stream -- quot/f )
+GENERIC# prompt. 1 ( stream prompt -- )
+
+: prompt ( -- str )
+    manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if*
+    auto-use? get [ " auto-use" append ] when ;
+
+SYMBOL: prompt-style
+H{
+    { background T{ rgba f 1 0.7 0.7 1 } }
+    { foreground COLOR: black }
+} prompt-style set-global
+
+M: object prompt.
+    nip prompt-style get-global format bl flush ;
 
 : parse-lines-interactive ( lines -- quot/f )
     [ parse-lines ] with-compilation-unit ;
@@ -48,7 +63,7 @@ SYMBOL: error-hook
 
 : call-error-hook ( error -- )
     error-continuation get error-hook get
-    call( error continuation -- ) ;
+    call( continuation error -- ) ;
 
 [ drop print-error-and-restarts ] error-hook set-global
 
@@ -82,7 +97,7 @@ t error-summary? set-global
             ] each
         ] tabular-output nl
     ] unless-empty ;
-    
+
 : trimmed-stack. ( seq -- )
     dup length max-stack-items get > [
         max-stack-items get cut*
@@ -97,15 +112,11 @@ t error-summary? set-global
         [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
     ] [ drop ] if ;
 
-: prompt. ( -- )
-    current-vocab name>> auto-use? get [ " - auto" append ] when "( " " )" surround
-    H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
-
-:: (listener) ( datastack -- )
+:: listener-step ( datastack -- datastack' )
     error-summary? get [ error-summary ] when
     visible-vars.
     datastack datastack.
-    prompt.
+    input-stream get prompt prompt.
 
     [
         read-quot [
@@ -118,13 +129,96 @@ t error-summary? set-global
         [ call-error-hook datastack ]
         [ rethrow ]
         if
-    ] recover
+    ] recover ;
 
-    (listener) ;
+: (listener) ( datastack -- )
+    listener-step (listener) ;
 
 PRIVATE>
 
+SYMBOL: interactive-vocabs
+
+{
+    "accessors"
+    "arrays"
+    "assocs"
+    "combinators"
+    "compiler.errors"
+    "compiler.units"
+    "continuations"
+    "debugger"
+    "definitions"
+    "editors"
+    "help"
+    "help.apropos"
+    "help.lint"
+    "help.vocabs"
+    "inspector"
+    "io"
+    "io.files"
+    "io.pathnames"
+    "kernel"
+    "listener"
+    "math"
+    "math.order"
+    "memory"
+    "namespaces"
+    "parser"
+    "prettyprint"
+    "see"
+    "sequences"
+    "slicing"
+    "sorting"
+    "stack-checker"
+    "strings"
+    "syntax"
+    "tools.annotations"
+    "tools.crossref"
+    "tools.deprecation"
+    "tools.destructors"
+    "tools.disassembler"
+    "tools.dispatch"
+    "tools.errors"
+    "tools.memory"
+    "tools.profiler.sampling"
+    "tools.test"
+    "tools.threads"
+    "tools.time"
+    "tools.walker"
+    "vocabs"
+    "vocabs.loader"
+    "vocabs.refresh"
+    "vocabs.hierarchy"
+    "words"
+} interactive-vocabs set-global
+
+: loaded-vocab? ( vocab-spec -- ? )
+    {
+        [ find-vocab-root not ]
+        [ source-loaded?>> +done+ eq? ]
+    } 1|| ;
+
+: use-loaded-vocabs ( vocabs -- )
+    [
+        lookup-vocab [
+            dup loaded-vocab? [ use-vocab ] [ drop ] if
+        ] when*
+    ] each ;
+
+: with-interactive-vocabs ( quot -- )
+    [
+        "scratchpad" set-current-vocab
+        interactive-vocabs get use-loaded-vocabs
+        call
+    ] with-manifest ; inline
+
 : listener ( -- )
-    [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
+    [
+        parser-quiet? off
+        [ { } (listener) ] with-return
+    ] with-interactive-vocabs ;
+
+: listener-main ( -- )
+    version-info print flush listener ;
 
-MAIN: listener
+MAIN: listener-main