111 lines
3.5 KiB
Factor
111 lines
3.5 KiB
Factor
! Copyright (C) 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: gadgets-text
|
|
USING: arrays definitions gadgets gadgets-controls gadgets-panes
|
|
generic hashtables help io kernel namespaces prettyprint styles
|
|
threads sequences vectors definitions parser words ;
|
|
|
|
TUPLE: interactor history output continuation queue busy? ;
|
|
|
|
C: interactor ( output -- gadget )
|
|
[ set-interactor-output ] keep
|
|
f <field> over set-gadget-delegate
|
|
V{ } clone over set-interactor-history
|
|
dup dup set-control-self ;
|
|
|
|
M: interactor graft*
|
|
f over set-interactor-busy? delegate graft* ;
|
|
|
|
: (interactor-eval) ( string interactor -- )
|
|
dup interactor-busy? [
|
|
2drop
|
|
] [
|
|
t over set-interactor-busy?
|
|
swap "\n" split <reversed> >vector
|
|
over set-interactor-queue
|
|
interactor-continuation schedule-thread
|
|
] if ;
|
|
|
|
SYMBOL: structured-input
|
|
|
|
: interactor-call ( quot gadget -- )
|
|
dup interactor-output [
|
|
"Command: " write over short.
|
|
] with-stream*
|
|
>r structured-input set-global
|
|
"\"structured-input\" \"gadgets-text\" lookup get-global call"
|
|
r> (interactor-eval) ;
|
|
|
|
: interactor-input. ( string interactor -- )
|
|
interactor-output [ dup print-input ] with-stream* ;
|
|
|
|
: interactor-eval ( string interactor -- )
|
|
dup control-model clear-doc
|
|
2dup interactor-history push-new
|
|
2dup interactor-input.
|
|
(interactor-eval) ;
|
|
|
|
: interactor-commit ( interactor -- )
|
|
dup interactor-busy? [
|
|
drop
|
|
] [
|
|
[ field-commit ] keep interactor-eval
|
|
] if ;
|
|
|
|
: quot-action ( interactor word -- )
|
|
over interactor-busy? [
|
|
2drop
|
|
] [
|
|
[ "[ " % over field-commit % " ] " % % ] "" make
|
|
swap interactor-eval
|
|
] if ;
|
|
|
|
: interactor-history. ( -- )
|
|
stdio get dup duplex-stream-out [
|
|
duplex-stream-in interactor-history
|
|
[ dup print-input ] each
|
|
] with-stream* ;
|
|
|
|
: token-action ( interactor quot -- )
|
|
over gadget-selection?
|
|
[ over T{ word-elt } select-elt ] unless
|
|
over gadget-selection add* swap interactor-call ;
|
|
|
|
: word-action ( interactor quot -- )
|
|
search token-action ;
|
|
|
|
: usable-words ( -- seq )
|
|
use get [ hash-values natural-sort ] map concat prune ;
|
|
|
|
interactor [
|
|
{ f "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] } ,
|
|
{ f "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] } ,
|
|
{ f "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] } ,
|
|
|
|
{
|
|
{ f "Stack effect" T{ key-down f { C+ A+ } "i" } "infer ." }
|
|
{ f "Single step" T{ key-down f { C+ A+ } "w" } "walk" }
|
|
{ f "Single step" T{ key-down f { C+ A+ } "t" } "time" }
|
|
} [ first4 [ quot-action ] curry 4array ] map %
|
|
|
|
{
|
|
{ f "See" T{ key-down f { A+ } "s" } [ see ] }
|
|
{ f "Help" T{ key-down f { A+ } "h" } [ help ] }
|
|
{ f "Callers" T{ key-down f { A+ } "u" } [ usage. ] }
|
|
{ f "Edit" T{ key-down f { A+ } "e" } [ edit ] }
|
|
{ f "Reload" T{ key-down f { A+ } "r" } [ reload ] }
|
|
{ f "Reload" T{ key-down f { A+ } "w" } [ watch ] }
|
|
} [ first4 [ word-action ] curry 4array ] map %
|
|
|
|
{
|
|
{ f "Apropos (all)" T{ key-down f { A+ } "a" } [ apropos ] }
|
|
{ f "Apropos (used)" T{ key-down f f "TAB" } [ usable-words (apropos) ] }
|
|
} [ first4 [ token-action ] curry 4array ] map %
|
|
] { } make define-commands
|
|
|
|
M: interactor stream-readln
|
|
dup interactor-queue empty? [
|
|
f over set-interactor-busy?
|
|
[ over set-interactor-continuation stop ] callcc0
|
|
] when interactor-queue pop ;
|