ui.theme: updates to color scheme.

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

diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index b28e3db941de7808edcd305689479e127aff0f99..36322b4fc6c53edd6027a614a10f8bfd314c91be 100644 (file)
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -1,14 +1,16 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs calendar combinators
-combinators.short-circuit concurrency.flags concurrency.mailboxes
-continuations destructors documents documents.elements fry hashtables
-help help.markup help.tips io io.styles kernel lexer listener locals
-math models models.arrow models.delay namespaces parser prettyprint
-sequences source-files.errors strings system threads
+combinators.short-circuit concurrency.flags
+concurrency.mailboxes continuations destructors documents
+documents.elements fonts fry hashtables help help.markup
+help.tips io io.styles kernel lexer listener literals locals
+math models models.arrow models.delay namespaces parser
+prettyprint sequences source-files.errors strings system threads
 tools.errors.model ui ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.glass ui.gadgets.labeled ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.theme
+ui.gadgets.scrollers ui.gadgets.status-bar ui.theme
+ui.gadgets.theme
 ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.operations
 ui.pens.solid ui.tools.browser ui.tools.common ui.tools.debugger
 ui.tools.error-list ui.tools.listener.completion
@@ -72,6 +74,7 @@ M: color-completion (word-at-caret) 2drop f ;
 
 : <interactor> ( -- gadget )
     interactor new-editor
+        theme-font-colors
         <flag> >>flag
         dup one-word-elt <element-model> >>token-model
         dup <word-model> >>word-model
@@ -93,13 +96,26 @@ M: interactor stream-element-type drop +character+ ;
 
 GENERIC: (print-input) ( object -- )
 
+SYMBOL: listener-input-style
+H{
+    { font-style bold }
+    { foreground $ text-color }
+} listener-input-style set-global
+
+SYMBOL: listener-word-style
+H{
+    { font-name "sans-serif" }
+    { font-style bold }
+    { foreground $ text-color }
+} listener-word-style set-global
+
 M: input (print-input)
-    dup presented associate
-    [ string>> H{ { font-style bold } } format ] with-nesting nl ;
+    dup presented associate [
+        string>> listener-input-style get-global format
+    ] with-nesting nl ;
 
 M: word (print-input)
-    "Command: " H{ { font-name "sans-serif" } { font-style bold } }
-    format . ;
+    "Command: " listener-word-style get-global format . ;
 
 : print-input ( object interactor -- )
     output>> [ (print-input) ] with-output-stream* ;
@@ -222,7 +238,7 @@ M: listener-gadget focusable-child*
     input>> dup popup>> or ;
 
 : wait-for-listener ( listener -- )
-    input>> flag>> wait-for-flag ;
+    input>> flag>> 5 seconds wait-for-flag-timeout ;
 
 : listener-busy? ( listener -- ? )
     input>> interactor-busy? ;
@@ -321,16 +337,30 @@ M: object accept-completion-hook 2drop ;
     [ history>> history-add drop ] [ control-value ] [ select-all ] tri
     parse-lines-interactive ;
 
-: <debugger-popup> ( error continuation -- popup )
-    over compute-restarts [ hide-glass ] <debugger>
+: do-recall? ( table error -- ? )
+    [ selection>> value>> not ] [ lexer-error? ] bi* and ;
+
+: recall-lexer-error ( interactor error -- )
+    over recall-previous go-to-error ;
+
+: make-restart-hook-quot ( error interactor -- quot )
+    over '[
+        dup hide-glass
+        _ do-recall? [ _ _ recall-lexer-error ] when
+    ] ;
+
+: frame-debugger ( debugger -- labeled )
     "Error" debugger-color <framed-labeled> ;
 
-: recall-on-lexer-error ( interactor error -- )
-    dup lexer-error? [ over recall-previous go-to-error ] [ 2drop ] if ;
+:: <debugger-popup> ( error continuation interactor -- popup )
+    error
+    continuation
+    error compute-restarts
+    error interactor make-restart-hook-quot
+    <debugger> frame-debugger ;
 
 : debugger-popup ( interactor error continuation -- )
-    2over recall-on-lexer-error
-    [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
+    pick <debugger-popup> one-line-elt swap show-listener-popup ;
 
 : try-parse ( lines -- quot/f )
     [ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ;
@@ -366,15 +396,17 @@ interactor "completion" f {
     { T{ key-down f f "TAB" } code-completion-popup }
     { T{ key-down f { C+ } "p" } recall-previous }
     { T{ key-down f { C+ } "n" } recall-next }
-    { T{ key-down f f "UP" } recall-previous }
-    { T{ key-down f f "DOWN" } recall-next }
     { T{ key-down f { C+ } "r" } history-completion-popup }
 } define-command-map
 
 : introduction. ( -- )
-    tip-of-the-day. nl
-    { $strong "Press " { $snippet "F1" } " at any time for help." } print-content nl
-    version-info print-content nl nl ;
+    [
+        H{ { font-size $ default-font-size } } [
+            { $tip-of-the-day } print-element nl
+            { $strong "Press " { $snippet "F1" } " at any time for help." } print-element nl
+            version-info print-element
+        ] with-style
+    ] with-default-style nl nl ;
 
 : listener-thread ( listener -- )
     dup listener-streams [