! 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 ;
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.
#! 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
: compiling ( word -- word parameter )
check-architecture
- "Compiling " write dup word. terpri flush
+ "Compiling " write dup unparse. terpri flush
dup word-def ;
GENERIC: (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 ;
: decompile ( word -- )
dup compiled? [
- "Decompiling " write dup word. terpri flush
+ "Decompiling " write dup unparse. terpri flush
[ word-primitive ] keep set-word-primitive
] [
drop
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 [
! 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 ;
SYMBOL: listener-prompt
SYMBOL: quit-flag
+SYMBOL: listener-hook
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.
[ 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
2dup incremental-loc
tuck update-cursor
prefer-incremental ;
+
+: clear-incremental ( incremental -- )
+ dup clear-gadget { 0 0 0 } swap set-incremental-cursor ;
! 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
<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 ;
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 ;
[ 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
[ word? ] "Usage" [ usage . ] define-command
[ word? ] "jEdit" [ jedit ] define-command
-[ [ gadget? ] is? ] "Display" [ ] define-command
+[ [ gadget? ] is? ] "Display" [ gadget. ] define-command