! 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
-make math models models.arrow models.delay namespaces parser
-prettyprint quotations 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.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
+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.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
ui.tools.listener.history ui.tools.listener.popups vocabs
vocabs.loader vocabs.parser vocabs.refresh words ;
IN: ui.tools.listener
: <interactor> ( -- gadget )
interactor new-editor
+ theme-font-colors
<flag> >>flag
dup one-word-elt <element-model> >>token-model
dup <word-model> >>word-model
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: "
- [
- "sans-serif" font-name ,,
- bold font-style ,,
- ] H{ } make format . ;
+ "Command: " listener-word-style get-global format . ;
: print-input ( object interactor -- )
output>> [ (print-input) ] with-output-stream* ;
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? ;
[ history>> history-add drop ] [ control-value ] [ select-all ] tri
parse-lines-interactive ;
-: <debugger-popup> ( error continuation -- popup )
- over compute-restarts [ hide-glass ] <debugger>
- "Error" debugger-color <framed-labeled> ;
+: do-recall? ( table error -- ? )
+ [ selection>> value>> not ] [ lexer-error? ] bi* and ;
-: debugger-popup ( interactor error continuation -- )
- [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
+: 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
+ ] ;
-: handle-parse-error ( interactor error -- )
- dup lexer-error? [ 2dup go-to-error error>> ] when
- error-continuation get
- debugger-popup ;
+: frame-debugger ( debugger -- labeled )
+ "Error" debugger-color <framed-labeled> ;
-: try-parse ( lines -- quot/f/error )
- [ read-quot-step ] [ nip ] recover ;
+:: <debugger-popup> ( error continuation interactor -- popup )
+ error
+ continuation
+ error compute-restarts
+ error interactor make-restart-hook-quot
+ <debugger> frame-debugger ;
-: handle-interactive ( interactor lines -- quot/f )
- try-parse dup quotation? [ nip ] [
- dup not [ drop insert-newline ] [
- handle-parse-error
- ] if f
- ] if ;
+: debugger-popup ( interactor error continuation -- )
+ pick <debugger-popup> one-line-elt swap show-listener-popup ;
+
+: try-parse ( lines -- quot/f )
+ [ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ;
M: interactor stream-read-quot ( stream -- quot/f )
- dup interactor-yield dup [ not ] [ callable? ] bi or
- [ nip ] [
- dupd handle-interactive dup quotation? [
- swap interactor-finish
- ] [ drop stream-read-quot ] if
- ] if ;
+ dup interactor-yield dup array? [
+ over interactor-finish try-parse
+ [ nip ] [ stream-read-quot ] if*
+ ] [ nip ] if ;
: interactor-operation ( gesture interactor -- ? )
[ token-model>> value>> ] keep word-at-caret
{ 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 [
projects / factor.git / blobdiff