ui listener shows the stack now, fixed gadget display command
parent
e6327cec9b
commit
a1f3680708
|
@ -1,5 +1,8 @@
|
|||
! Copyright (C) 2003, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: words
|
||||
DEFER: literalize
|
||||
|
||||
IN: namespaces
|
||||
USING: hashtables kernel kernel-internals lists math sequences
|
||||
strings vectors words ;
|
||||
|
@ -114,11 +117,6 @@ SYMBOL: building
|
|||
push
|
||||
] ifte ;
|
||||
|
||||
: literal, ( word -- )
|
||||
#! Append some code that pushes the word on the stack. Used
|
||||
#! when building quotations.
|
||||
literalize % ;
|
||||
|
||||
: unique, ( obj -- )
|
||||
#! Add the object to the sequence being built with make-seq
|
||||
#! unless an equal object has already been added.
|
||||
|
@ -128,6 +126,11 @@ SYMBOL: building
|
|||
#! Append to the sequence being built with make-seq.
|
||||
building get swap nappend ;
|
||||
|
||||
: literal, ( word -- )
|
||||
#! Append some code that pushes the word on the stack. Used
|
||||
#! when building quotations.
|
||||
literalize % ;
|
||||
|
||||
: make-vector ( quot -- vector )
|
||||
100 <vector> make-seq ; inline
|
||||
|
||||
|
|
|
@ -13,7 +13,7 @@ kernel lists math namespaces prettyprint io words ;
|
|||
|
||||
: compiling ( word -- word parameter )
|
||||
check-architecture
|
||||
"Compiling " write dup word. terpri flush
|
||||
"Compiling " write dup unparse. terpri flush
|
||||
dup word-def ;
|
||||
|
||||
GENERIC: (compile) ( word -- )
|
||||
|
@ -43,7 +43,7 @@ M: compound (compile) ( word -- )
|
|||
"compile" get [ word compile ] when ; parsing
|
||||
|
||||
: cannot-compile ( word error -- )
|
||||
"Cannot compile " write swap word. terpri print-error ;
|
||||
"Cannot compile " write swap unparse. terpri print-error ;
|
||||
|
||||
: try-compile ( word -- )
|
||||
[ compile ] [ [ cannot-compile ] when* ] catch ;
|
||||
|
@ -52,7 +52,7 @@ M: compound (compile) ( word -- )
|
|||
|
||||
: decompile ( word -- )
|
||||
dup compiled? [
|
||||
"Decompiling " write dup word. terpri flush
|
||||
"Decompiling " write dup unparse. terpri flush
|
||||
[ word-primitive ] keep set-word-primitive
|
||||
] [
|
||||
drop
|
||||
|
|
|
@ -4,23 +4,8 @@ IN: prettyprint
|
|||
USING: generic hashtables io kernel lists namespaces sequences
|
||||
streams strings styles unparser words ;
|
||||
|
||||
! Prettyprinting words
|
||||
: vocab-actions ( search -- list )
|
||||
[
|
||||
[[ "Words" "words ." ]]
|
||||
[[ "Use" "use+" ]]
|
||||
[[ "In" "\"in\" set" ]]
|
||||
] ;
|
||||
|
||||
: vocab-attrs ( vocab -- attrs )
|
||||
#! Words without a vocabulary do not get a link or an action
|
||||
#! popup.
|
||||
unparse vocab-actions <actions> "actions" swons unit ;
|
||||
|
||||
: vocab. ( vocab -- ) dup vocab-attrs write-attr ;
|
||||
|
||||
: prettyprint-IN: ( word -- )
|
||||
\ IN: unparse. bl word-vocabulary vocab. terpri ;
|
||||
\ IN: unparse. bl word-vocabulary write terpri ;
|
||||
|
||||
: prettyprint-prop ( word prop -- )
|
||||
tuck word-name word-prop [
|
||||
|
|
|
@ -39,7 +39,7 @@ prettyprint sequences io strings words styles ;
|
|||
! remaining -- input
|
||||
: jedit-write-attr ( str style -- )
|
||||
CHAR: w write
|
||||
[ swap . "USE: styles" print [ car presented = not ] subset . ] string-out
|
||||
[ drop . f . ] string-out
|
||||
dup write-len write ;
|
||||
|
||||
TUPLE: jedit-stream ;
|
||||
|
|
|
@ -6,6 +6,7 @@ presentation sequences strings styles unparser vectors words ;
|
|||
|
||||
SYMBOL: listener-prompt
|
||||
SYMBOL: quit-flag
|
||||
SYMBOL: listener-hook
|
||||
|
||||
global [ " " listener-prompt set ] bind
|
||||
|
||||
|
@ -32,8 +33,10 @@ global [ " " listener-prompt set ] bind
|
|||
|
||||
: listen ( -- )
|
||||
#! Wait for user input, and execute.
|
||||
listener-prompt get write flush
|
||||
[ read-multiline [ call ] [ bye ] ifte ] try ;
|
||||
listener-prompt get write flush [
|
||||
read-multiline
|
||||
[ call listener-hook get call ] [ bye ] ifte
|
||||
] try ;
|
||||
|
||||
: listener ( -- )
|
||||
#! Run a listener loop that executes user input.
|
||||
|
|
|
@ -15,6 +15,10 @@ sequences ;
|
|||
[ remove-gadget ] [ 2drop ] ifte
|
||||
] when* ;
|
||||
|
||||
: clear-gadget ( gadget -- )
|
||||
dup gadget-children [ f swap set-gadget-parent ] each
|
||||
f over set-gadget-children relayout ;
|
||||
|
||||
: (add-gadget) ( gadget box -- )
|
||||
#! This is inefficient.
|
||||
over unparent
|
||||
|
|
|
@ -44,3 +44,6 @@ M: incremental layout* drop ;
|
|||
2dup incremental-loc
|
||||
tuck update-cursor
|
||||
prefer-incremental ;
|
||||
|
||||
: clear-incremental ( incremental -- )
|
||||
dup clear-gadget { 0 0 0 } swap set-incremental-cursor ;
|
||||
|
|
|
@ -1,10 +1,16 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic io kernel listener math namespaces styles threads ;
|
||||
USING: generic io kernel listener math namespaces prettyprint
|
||||
sequences styles threads ;
|
||||
|
||||
SYMBOL: stack-display
|
||||
|
||||
: ui.s ( -- )
|
||||
stack-display get dup pane-clear [
|
||||
datastack reverse [ unparse. terpri ] each
|
||||
] with-stream* ;
|
||||
|
||||
: init-world
|
||||
global [
|
||||
<world> world set
|
||||
|
@ -27,7 +33,12 @@ SYMBOL: stack-display
|
|||
<pane> dup stack-display set <scroller>
|
||||
3/4 <y-splitter> add-layer
|
||||
|
||||
[ pane get [ clear print-banner listener ] with-stream ] in-thread
|
||||
[
|
||||
pane get [
|
||||
[ ui.s ] listener-hook set
|
||||
clear print-banner listener
|
||||
] with-stream
|
||||
] in-thread
|
||||
|
||||
pane get request-focus
|
||||
] bind ;
|
||||
|
|
|
@ -63,6 +63,9 @@ C: pane ( -- pane )
|
|||
M: pane focusable-child* ( pane -- editor )
|
||||
pane-input ;
|
||||
|
||||
: pane-clear ( pane -- )
|
||||
dup pane-output clear-incremental pane-current clear-gadget ;
|
||||
|
||||
: pane-write-1 ( style text pane -- )
|
||||
>r <presentation> r> pane-current add-gadget ;
|
||||
|
||||
|
|
|
@ -43,7 +43,7 @@ global [ 100 <vector> commands set ] bind
|
|||
[ 2nip ] [ drop <styled-label> dup init-commands ] ifte ;
|
||||
|
||||
: gadget. ( gadget -- )
|
||||
gadget swons unit "" swap write-attr ;
|
||||
gadget swons unit "" swap write-attr terpri ;
|
||||
|
||||
[ drop t ] "Prettyprint" [ prettyprint ] define-command
|
||||
[ drop t ] "Inspect" [ inspect ] define-command
|
||||
|
@ -54,4 +54,4 @@ global [ 100 <vector> commands set ] bind
|
|||
[ word? ] "Usage" [ usage . ] define-command
|
||||
[ word? ] "jEdit" [ jedit ] define-command
|
||||
|
||||
[ [ gadget? ] is? ] "Display" [ ] define-command
|
||||
[ [ gadget? ] is? ] "Display" [ gadget. ] define-command
|
||||
|
|
Loading…
Reference in New Issue