UI tool improvements
slava
parent
bded83ef35
commit
06f2cfe8d3
|
|
@ -36,6 +36,7 @@ PROVIDE: library/ui {
|
|||
"text/interactor.factor"
|
||||
"gadgets/presentations.factor"
|
||||
"ui.factor"
|
||||
"tools/tools.factor"
|
||||
"tools/listener.factor"
|
||||
"tools/walker.factor"
|
||||
"tools/search.factor"
|
||||
|
|
@ -43,6 +44,7 @@ PROVIDE: library/ui {
|
|||
"tools/help.factor"
|
||||
"tools/dataflow.factor"
|
||||
"tools/workspace.factor"
|
||||
"tools/operations.factor"
|
||||
} {
|
||||
"test/models.factor"
|
||||
"test/document.factor"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: arrays sequences kernel gadgets-panes definitions
|
|||
prettyprint gadgets-theme gadgets-borders gadgets
|
||||
generic gadgets-scrolling math io words models styles
|
||||
namespaces gadgets-tracks gadgets-presentations gadgets-grids
|
||||
gadgets-frames help gadgets-buttons gadgets-search tools ;
|
||||
gadgets-workspace gadgets-frames help gadgets-buttons
|
||||
gadgets-search tools ;
|
||||
IN: gadgets-browser
|
||||
|
||||
TUPLE: browser navigator definitions search ;
|
||||
|
|
@ -104,3 +105,10 @@ browser {
|
|||
{ "Clear" T{ key-down f f "CLEAR" } [ clear-browser ] }
|
||||
}
|
||||
} define-commands
|
||||
|
||||
M: browser call-tool*
|
||||
over vocab-link? [
|
||||
>r vocab-link-name r> show-vocab
|
||||
] [
|
||||
show-word
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ USING: namespaces arrays sequences io inference math kernel
|
|||
generic prettyprint words gadgets opengl gadgets-panes
|
||||
gadgets-labels gadgets-theme gadgets-presentations
|
||||
gadgets-buttons gadgets-borders gadgets-scrolling
|
||||
gadgets-frames optimizer models ;
|
||||
gadgets-frames gadgets-workspace optimizer models ;
|
||||
|
||||
: shuffle-in dup shuffle-in-d swap shuffle-in-r append ;
|
||||
|
||||
|
|
@ -111,35 +111,30 @@ M: object node>gadget
|
|||
{ 5 5 } over set-pack-gap
|
||||
swap <node-gadget> dup faint-boundary ;
|
||||
|
||||
: (compute-heights) ( node -- )
|
||||
[
|
||||
[ node-d-height ] keep
|
||||
[ node-r-height ] keep
|
||||
[ 3array , ] keep
|
||||
node-successor (compute-heights)
|
||||
] when* ;
|
||||
|
||||
: node-in-d# node-in-d length ;
|
||||
: node-out-d# node-out-d length ;
|
||||
|
||||
: node-in-r# node-in-r length ;
|
||||
: node-out-r# node-out-r length ;
|
||||
|
||||
SYMBOL: d-height
|
||||
SYMBOL: r-height
|
||||
|
||||
: (compute-heights) ( node -- )
|
||||
[
|
||||
dup node-in-d# d-height [ swap - ] change
|
||||
dup node-in-r# r-height [ swap - ] change
|
||||
d-height get r-height get pick 3array ,
|
||||
dup node-out-d# d-height [ + ] change
|
||||
dup node-out-r# r-height [ + ] change
|
||||
node-successor (compute-heights)
|
||||
] when* ;
|
||||
|
||||
: normalize-d-height ( seq -- seq )
|
||||
[ [ first ] map infimum ] keep
|
||||
[ [ dup first swap third node-in-d# - ] map infimum ] keep
|
||||
[ first3 >r >r swap - r> r> 3array ] map-with ;
|
||||
|
||||
: normalize-r-height ( seq -- seq )
|
||||
[ [ second ] map infimum ] keep
|
||||
[ [ dup second swap third node-in-r# - ] map infimum ] keep
|
||||
[ first3 >r rot - r> 3array ] map-with ;
|
||||
|
||||
: compute-heights ( nodes -- pairs )
|
||||
[ 0 d-height set 0 r-height set (compute-heights) ] { } make
|
||||
[ (compute-heights) ] { } make
|
||||
normalize-d-height normalize-r-height ;
|
||||
|
||||
: node-r-skew-1 ( node -- n )
|
||||
|
|
@ -149,17 +144,18 @@ SYMBOL: r-height
|
|||
dup node-in-d# over node-out-r# [-] swap node-out-d# [-] ;
|
||||
|
||||
SYMBOL: prev-node
|
||||
|
||||
: node-r-skew ( node -- n )
|
||||
node-r-skew-1 prev-node get [ node-r-skew-2 - ] when* ;
|
||||
|
||||
: print-node ( d-height r-height node -- )
|
||||
[
|
||||
[
|
||||
pick over node-in-d# + 0 <height-gadget> ,
|
||||
pick 0 <height-gadget> ,
|
||||
2dup node-in-r# + over node-r-skew <height-gadget> ,
|
||||
] { } make make-pile ,
|
||||
[
|
||||
rot 0 <height-gadget> ,
|
||||
rot over node-in-d# - 0 <height-gadget> ,
|
||||
node>gadget ,
|
||||
0 <height-gadget> ,
|
||||
] { } make make-pile 1 over set-pack-fill ,
|
||||
|
|
@ -190,3 +186,12 @@ C: dataflow-gadget ( -- gadget )
|
|||
f <history> over set-dataflow-gadget-history {
|
||||
{ [ <dataflow-pane> ] f [ <scroller> ] @center }
|
||||
} make-frame* ;
|
||||
|
||||
M: dataflow-gadget call-tool* ( node dataflow -- )
|
||||
dup dataflow-gadget-history add-history
|
||||
dataflow-gadget-history set-model ;
|
||||
|
||||
IN: tools
|
||||
|
||||
: show-dataflow ( quot -- )
|
||||
dataflow optimize dataflow-gadget call-tool ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: gadgets-help
|
||||
USING: gadgets gadgets-borders gadgets-buttons gadgets-frames
|
||||
gadgets-panes gadgets-search gadgets-scrolling help kernel
|
||||
models namespaces sequences gadgets-tracks ;
|
||||
models namespaces sequences gadgets-tracks gadgets-workspace ;
|
||||
|
||||
TUPLE: help-gadget history search ;
|
||||
|
||||
|
|
@ -36,3 +36,5 @@ C: help-gadget ( -- gadget )
|
|||
} { 0 1 } make-track* ;
|
||||
|
||||
M: help-gadget focusable-child* help-gadget-search ;
|
||||
|
||||
M: help-gadget call-tool* show-help ;
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
IN: gadgets-listener
|
||||
USING: arrays gadgets gadgets-frames gadgets-labels
|
||||
gadgets-panes gadgets-scrolling gadgets-text gadgets-theme
|
||||
gadgets-tracks generic hashtables tools io
|
||||
gadgets-tracks gadgets-workspace generic hashtables tools io
|
||||
kernel listener math models namespaces parser prettyprint
|
||||
sequences shells styles threads words memory ;
|
||||
sequences shells strings styles threads words memory ;
|
||||
|
||||
TUPLE: listener-gadget input output stack ;
|
||||
|
||||
|
|
@ -63,3 +63,25 @@ M: listener-gadget focusable-child*
|
|||
|
||||
: clear-output ( -- )
|
||||
stdio get duplex-stream-out pane-clear ;
|
||||
|
||||
G: call-listener ( quot/string listener -- )
|
||||
1 standard-combination ;
|
||||
|
||||
M: quotation call-listener
|
||||
listener-gadget-input interactor-call ;
|
||||
|
||||
M: string call-listener
|
||||
listener-gadget-input set-editor-text ;
|
||||
|
||||
M: input call-listener
|
||||
>r input-string r> call-listener ;
|
||||
|
||||
M: listener-gadget call-tool* ( quot/string listener -- )
|
||||
call-listener ;
|
||||
|
||||
: listener-run-files ( seq -- )
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
[ [ run-file ] each ] curry listener-gadget call-tool
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,230 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-workspace
|
||||
USING: definitions gadgets gadgets-browser gadgets-dataflow
|
||||
gadgets-help gadgets-listener gadgets-text gadgets-workspace
|
||||
hashtables help inference kernel namespaces parser prettyprint
|
||||
scratchpad sequences strings styles syntax test tools words
|
||||
generic ;
|
||||
|
||||
V{ } clone operations set-global
|
||||
|
||||
: define-operation ( class props -- )
|
||||
<operation> operations get push-new ;
|
||||
|
||||
M: operation invoke-command ( target operation -- )
|
||||
dup command-quot swap operation-listener?
|
||||
[ curry listener-gadget call-tool ] [ call ] if ;
|
||||
|
||||
: modify-operation ( quot operation -- operation )
|
||||
clone
|
||||
[ command-quot append ] keep
|
||||
[ set-command-quot ] keep ;
|
||||
|
||||
: modify-operations ( quot operations -- operations )
|
||||
[ modify-operation ] map-with ;
|
||||
|
||||
: modify-listener-operation ( quot operation -- operation )
|
||||
clone t over set-operation-listener?
|
||||
modify-operation ;
|
||||
|
||||
: modify-listener-operations ( quot operations -- operations )
|
||||
[ modify-listener-operation ] map-with ;
|
||||
|
||||
! Objects
|
||||
[ drop t ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Inspect" }
|
||||
{ +quot+ [ inspect ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Input
|
||||
[ input? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Input" }
|
||||
{ +quot+ [ listener-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Words
|
||||
[ word? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Browse" }
|
||||
{ +gesture+ T{ key-down f { A+ } "b" } }
|
||||
{ +quot+ [ browser call-tool ] }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +button+ 2 }
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Edit" }
|
||||
{ +gesture+ T{ key-down f { A+ } "e" } }
|
||||
{ +quot+ [ edit ] }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +button+ 3 }
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Documentation" }
|
||||
{ +gesture+ T{ key-down f { A+ } "h" } }
|
||||
{ +quot+ [ help-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Usage" }
|
||||
{ +gesture+ T{ key-down f { A+ } "u" } }
|
||||
{ +quot+ [ usage. ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Reload" }
|
||||
{ +gesture+ T{ key-down f { A+ } "r" } }
|
||||
{ +quot+ [ reload ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Watch" }
|
||||
{ +quot+ [ watch ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Vocabularies
|
||||
[ vocab-link? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Browse" }
|
||||
{ +quot+ [ browser call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Link
|
||||
[ link? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Follow" }
|
||||
{ +quot+ [ help-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
[ link? ] H{
|
||||
{ +button+ 2 }
|
||||
{ +name+ "Edit" }
|
||||
{ +quot+ [ edit ] }
|
||||
} define-operation
|
||||
|
||||
[ word-link? ] H{
|
||||
{ +button+ 3 }
|
||||
{ +name+ "Definition" }
|
||||
{ +quot+ [ link-name browser call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Strings
|
||||
[ string? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Apropos (all)" }
|
||||
{ +gesture+ T{ key-down f { A+ } "a" } }
|
||||
{ +quot+ [ apropos ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
: usable-words ( -- seq )
|
||||
[
|
||||
use get [ hash-values [ dup set ] each ] each
|
||||
] make-hash hash-values natural-sort ;
|
||||
|
||||
[ string? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Apropos (used)" }
|
||||
{ +gesture+ T{ key-down f f "TAB" } }
|
||||
{ +quot+ [ usable-words (apropos) ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Quotations
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Infer" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "i" } }
|
||||
{ +quot+ [ infer . ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Dataflow" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "d" } }
|
||||
{ +quot+ [ show-dataflow ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Walk" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "w" } }
|
||||
{ +quot+ [ walk ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Time" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "t" } }
|
||||
{ +quot+ [ time ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Dataflow nodes
|
||||
[ word? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Word dataflow" }
|
||||
{ +quot+ [ word-def dataflow-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
[ [ node? ] is? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +group+ "Nodes" }
|
||||
{ +name+ "Quotation dataflow" }
|
||||
{ +quot+ [ dataflow-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Define commands in terms of operations
|
||||
|
||||
! Tile commands
|
||||
tile
|
||||
[ tile-definition ] \ word class-operations modify-operations
|
||||
[ command-name "Browse" = not ] subset
|
||||
T{ command f f "Close" f [ close-tile ] } add*
|
||||
define-commands*
|
||||
|
||||
! Interactor commands
|
||||
: selected-word ( editor -- string )
|
||||
dup gadget-selection?
|
||||
[ dup T{ word-elt } select-elt ] unless
|
||||
gadget-selection ;
|
||||
|
||||
: word-action ( target -- quot )
|
||||
selected-word search ;
|
||||
|
||||
: quot-action ( quot -- quot )
|
||||
field-commit parse ;
|
||||
|
||||
interactor [
|
||||
{
|
||||
"Listener"
|
||||
{ "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] }
|
||||
{ "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] }
|
||||
} <commands> %
|
||||
|
||||
[ word-action ] \ word class-operations modify-listener-operations %
|
||||
[ selected-word ] string class-operations modify-listener-operations %
|
||||
[ quot-action ] quotation class-operations modify-listener-operations %
|
||||
|
||||
{
|
||||
"Listener"
|
||||
{ "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] }
|
||||
{ "Clear output" T{ key-down f f "CLEAR" } [ [ clear-output ] swap interactor-call ] }
|
||||
{ "Clear stack" T{ key-down f { C+ } "CLEAR" } [ [ clear ] swap interactor-call ] }
|
||||
} <commands> %
|
||||
] { } make define-commands*
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-workspace
|
||||
USING: gadgets gadgets-books gadgets-controls gadgets-workspace
|
||||
generic kernel models scratchpad sequences syntax ;
|
||||
|
||||
DEFER: workspace-window
|
||||
|
||||
GENERIC: call-tool* ( arg tool -- )
|
||||
|
||||
TUPLE: workspace ;
|
||||
|
||||
TUPLE: tool gadget ;
|
||||
|
||||
: show-tool ( class workspace -- tool )
|
||||
[ book-pages [ tool-gadget class eq? ] find-with swap ] keep
|
||||
control-model set-model* ;
|
||||
|
||||
: select-tool ( workspace class -- ) swap show-tool drop ;
|
||||
|
||||
: find-workspace ( -- workspace )
|
||||
[ workspace? ] find-window
|
||||
[ world-gadget ] [ workspace-window find-workspace ] if* ;
|
||||
|
||||
: call-tool ( arg class -- )
|
||||
find-workspace show-tool call-tool* ;
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
IN: gadgets-walker
|
||||
USING: arrays errors gadgets gadgets-buttons gadgets-frames
|
||||
gadgets-listener gadgets-panes gadgets-scrolling gadgets-text
|
||||
gadgets-tracks generic hashtables tools
|
||||
gadgets-tracks gadgets-workspace generic hashtables tools
|
||||
interpreter io kernel kernel-internals listener math models
|
||||
namespaces sequences shells threads vectors ;
|
||||
|
||||
|
|
@ -60,3 +60,35 @@ C: walker-gadget ( -- gadget )
|
|||
{ [ walker-gadget-model$ <retainstack-display> ] f f 1/4 }
|
||||
{ [ walker-gadget-model$ <callstack-display> ] f f 1/3 }
|
||||
} { 0 1 } make-track* ;
|
||||
|
||||
M: walker-gadget call-tool* ( continuation walker -- )
|
||||
dup reset-walker [
|
||||
V{ } clone meta-history set
|
||||
restore-normally
|
||||
] with-walker ;
|
||||
|
||||
: walker-inspect ( walker -- )
|
||||
walker-gadget-ns [ meta-interp get ] bind
|
||||
[ inspect ] curry listener-gadget call-tool ;
|
||||
|
||||
: walker-step-all ( walker -- )
|
||||
dup [ step-all ] walker-command reset-walker
|
||||
find-workspace listener-gadget select-tool ;
|
||||
|
||||
walker-gadget {
|
||||
{
|
||||
"Walker"
|
||||
{ "Step" T{ key-down f f "s" } [ walker-step ] }
|
||||
{ "Step in" T{ key-down f f "i" } [ walker-step-in ] }
|
||||
{ "Step out" T{ key-down f f "o" } [ walker-step-out ] }
|
||||
{ "Step back" T{ key-down f f "b" } [ walker-step-back ] }
|
||||
{ "Continue" T{ key-down f f "c" } [ walker-step-all ] }
|
||||
{ "Inspect" T{ key-down f f "n" } [ walker-inspect ] }
|
||||
}
|
||||
} define-commands
|
||||
|
||||
[ walker-gadget call-tool stop ] break-hook set-global
|
||||
|
||||
IN: tools
|
||||
|
||||
: walk ( quot -- ) [ break ] swap append call ;
|
||||
|
|
|
|||
|
|
@ -1,18 +1,11 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays compiler gadgets gadgets-listener gadgets-buttons
|
||||
gadgets-walker gadgets-help gadgets-walker sequences
|
||||
gadgets-browser gadgets-books gadgets-frames gadgets-controls
|
||||
gadgets-grids gadgets-presentations kernel models namespaces
|
||||
styles words help parser tools memory generic threads
|
||||
gadgets-text gadgets-dataflow definitions inference test
|
||||
prettyprint math strings hashtables tools modules interpreter
|
||||
optimizer inference ;
|
||||
IN: gadgets-workspace
|
||||
|
||||
GENERIC: call-tool* ( arg tool -- )
|
||||
|
||||
TUPLE: tool gadget ;
|
||||
USING: arrays compiler gadgets gadgets-books gadgets-browser
|
||||
gadgets-buttons gadgets-controls gadgets-dataflow gadgets-frames
|
||||
gadgets-grids gadgets-help gadgets-listener
|
||||
gadgets-presentations gadgets-walker gadgets-workspace generic
|
||||
kernel math modules scratchpad sequences syntax words ;
|
||||
|
||||
C: tool ( gadget -- tool )
|
||||
{
|
||||
|
|
@ -24,8 +17,6 @@ M: tool focusable-child* tool-gadget ;
|
|||
|
||||
M: tool call-tool* tool-gadget call-tool* ;
|
||||
|
||||
TUPLE: workspace ;
|
||||
|
||||
: workspace-tabs
|
||||
{
|
||||
{ "Listener" <listener-gadget> }
|
||||
|
|
@ -58,23 +49,10 @@ M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
|
|||
[ init-tabs ] keep
|
||||
open-window ;
|
||||
|
||||
: show-tool ( class workspace -- tool )
|
||||
[ book-pages [ tool-gadget class eq? ] find-with swap ] keep
|
||||
control-model set-model* ;
|
||||
|
||||
: find-workspace ( -- workspace )
|
||||
[ workspace? ] find-window
|
||||
[ world-gadget ] [ workspace-window find-workspace ] if* ;
|
||||
|
||||
: call-tool ( arg class -- )
|
||||
find-workspace show-tool call-tool* ;
|
||||
|
||||
: commands-window ( workspace -- )
|
||||
dup find-world world-focus [ ] [ gadget-child ] ?if
|
||||
[ commands. ] "Commands" pane-window ;
|
||||
|
||||
: select-tool ( workspace class -- ) swap show-tool drop ;
|
||||
|
||||
: tool-window ( class -- ) workspace-window show-tool drop ;
|
||||
|
||||
workspace {
|
||||
|
|
@ -101,298 +79,3 @@ workspace {
|
|||
{ "Recompile changed words" T{ key-down f f "F8" } [ drop [ recompile ] listener-gadget call-tool ] }
|
||||
}
|
||||
} define-commands
|
||||
|
||||
! Walker tool
|
||||
IN: gadgets-walker
|
||||
|
||||
M: walker-gadget call-tool* ( continuation walker -- )
|
||||
dup reset-walker [
|
||||
V{ } clone meta-history set
|
||||
restore-normally
|
||||
] with-walker ;
|
||||
|
||||
: walker-inspect ( walker -- )
|
||||
walker-gadget-ns [ meta-interp get ] bind
|
||||
[ inspect ] curry listener-gadget call-tool ;
|
||||
|
||||
: walker-step-all ( walker -- )
|
||||
dup [ step-all ] walker-command reset-walker
|
||||
find-workspace listener-gadget select-tool ;
|
||||
|
||||
walker-gadget {
|
||||
{
|
||||
"Walker"
|
||||
{ "Step" T{ key-down f f "s" } [ walker-step ] }
|
||||
{ "Step in" T{ key-down f f "i" } [ walker-step-in ] }
|
||||
{ "Step out" T{ key-down f f "o" } [ walker-step-out ] }
|
||||
{ "Step back" T{ key-down f f "b" } [ walker-step-back ] }
|
||||
{ "Continue" T{ key-down f f "c" } [ walker-step-all ] }
|
||||
{ "Inspect" T{ key-down f f "n" } [ walker-inspect ] }
|
||||
}
|
||||
} define-commands
|
||||
|
||||
[ walker-gadget call-tool stop ] break-hook set-global
|
||||
|
||||
! Dataflow tool
|
||||
M: dataflow-gadget call-tool* ( node dataflow -- )
|
||||
dup dataflow-gadget-history add-history
|
||||
dataflow-gadget-history set-model ;
|
||||
|
||||
IN: tools
|
||||
|
||||
: walk ( quot -- ) [ break ] swap append call ;
|
||||
|
||||
: show-dataflow ( quot -- )
|
||||
dataflow optimize dataflow-gadget call-tool ;
|
||||
|
||||
IN: gadgets-workspace
|
||||
|
||||
! Listener tool
|
||||
G: call-listener ( quot/string listener -- )
|
||||
1 standard-combination ;
|
||||
|
||||
M: quotation call-listener
|
||||
listener-gadget-input interactor-call ;
|
||||
|
||||
M: string call-listener
|
||||
listener-gadget-input set-editor-text ;
|
||||
|
||||
M: input call-listener
|
||||
>r input-string r> call-listener ;
|
||||
|
||||
M: listener-gadget call-tool* ( quot/string listener -- )
|
||||
call-listener ;
|
||||
|
||||
: listener-run-files ( seq -- )
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
[ [ run-file ] each ] curry listener-gadget call-tool
|
||||
] if ;
|
||||
|
||||
! Browser tool
|
||||
M: browser call-tool*
|
||||
over vocab-link? [
|
||||
>r vocab-link-name r> show-vocab
|
||||
] [
|
||||
show-word
|
||||
] if ;
|
||||
|
||||
! Help tool
|
||||
M: help-gadget call-tool* show-help ;
|
||||
|
||||
! Operations
|
||||
V{ } clone operations set-global
|
||||
|
||||
: define-operation ( class props -- )
|
||||
<operation> operations get push-new ;
|
||||
|
||||
M: operation invoke-command ( target operation -- )
|
||||
dup command-quot swap operation-listener?
|
||||
[ curry listener-gadget call-tool ] [ call ] if ;
|
||||
|
||||
: modify-operation ( quot operation -- operation )
|
||||
clone
|
||||
[ command-quot append ] keep
|
||||
[ set-command-quot ] keep ;
|
||||
|
||||
: modify-operations ( quot operations -- operations )
|
||||
[ modify-operation ] map-with ;
|
||||
|
||||
: modify-listener-operation ( quot operation -- operation )
|
||||
clone t over set-operation-listener?
|
||||
modify-operation ;
|
||||
|
||||
: modify-listener-operations ( quot operations -- operations )
|
||||
[ modify-listener-operation ] map-with ;
|
||||
|
||||
! Objects
|
||||
[ drop t ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Inspect" }
|
||||
{ +quot+ [ inspect ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Input
|
||||
[ input? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Input" }
|
||||
{ +quot+ [ listener-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Words
|
||||
[ word? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Browse" }
|
||||
{ +gesture+ T{ key-down f { A+ } "b" } }
|
||||
{ +quot+ [ browser call-tool ] }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +button+ 2 }
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Edit" }
|
||||
{ +gesture+ T{ key-down f { A+ } "e" } }
|
||||
{ +quot+ [ edit ] }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +button+ 3 }
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Documentation" }
|
||||
{ +gesture+ T{ key-down f { A+ } "h" } }
|
||||
{ +quot+ [ help-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Usage" }
|
||||
{ +gesture+ T{ key-down f { A+ } "u" } }
|
||||
{ +quot+ [ usage. ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Reload" }
|
||||
{ +gesture+ T{ key-down f { A+ } "r" } }
|
||||
{ +quot+ [ reload ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ word? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Watch" }
|
||||
{ +quot+ [ watch ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Vocabularies
|
||||
[ vocab-link? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Browse" }
|
||||
{ +quot+ [ browser call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Link
|
||||
[ link? ] H{
|
||||
{ +button+ 1 }
|
||||
{ +name+ "Follow" }
|
||||
{ +quot+ [ help-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
[ link? ] H{
|
||||
{ +button+ 2 }
|
||||
{ +name+ "Edit" }
|
||||
{ +quot+ [ edit ] }
|
||||
} define-operation
|
||||
|
||||
[ word-link? ] H{
|
||||
{ +button+ 3 }
|
||||
{ +name+ "Definition" }
|
||||
{ +quot+ [ link-name browser call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Strings
|
||||
[ string? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Apropos (all)" }
|
||||
{ +gesture+ T{ key-down f { A+ } "a" } }
|
||||
{ +quot+ [ apropos ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
: usable-words ( -- seq )
|
||||
[
|
||||
use get [ hash-values [ dup set ] each ] each
|
||||
] make-hash hash-values natural-sort ;
|
||||
|
||||
[ string? ] H{
|
||||
{ +group+ "Words" }
|
||||
{ +name+ "Apropos (used)" }
|
||||
{ +gesture+ T{ key-down f f "TAB" } }
|
||||
{ +quot+ [ usable-words (apropos) ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Quotations
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Infer" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "i" } }
|
||||
{ +quot+ [ infer . ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Dataflow" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "d" } }
|
||||
{ +quot+ [ show-dataflow ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Walk" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "w" } }
|
||||
{ +quot+ [ walk ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ quotation? ] H{
|
||||
{ +group+ "Quotations" }
|
||||
{ +name+ "Time" }
|
||||
{ +gesture+ T{ key-down f { C+ A+ } "t" } }
|
||||
{ +quot+ [ time ] }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Dataflow nodes
|
||||
[ node? ] H{
|
||||
{ +group+ "Nodes" }
|
||||
{ +name+ "Display" }
|
||||
{ +quot+ [ dataflow-gadget call-tool ] }
|
||||
} define-operation
|
||||
|
||||
! Define commands in terms of operations
|
||||
|
||||
! Tile commands
|
||||
tile
|
||||
[ tile-definition ] \ word class-operations modify-operations
|
||||
[ command-name "Browse" = not ] subset
|
||||
T{ command f f "Close" f [ close-tile ] } add*
|
||||
define-commands*
|
||||
|
||||
! Interactor commands
|
||||
: selected-word ( editor -- string )
|
||||
dup gadget-selection?
|
||||
[ dup T{ word-elt } select-elt ] unless
|
||||
gadget-selection ;
|
||||
|
||||
: word-action ( target -- quot )
|
||||
selected-word search ;
|
||||
|
||||
: quot-action ( quot -- quot )
|
||||
field-commit parse ;
|
||||
|
||||
interactor [
|
||||
{
|
||||
"Listener"
|
||||
{ "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] }
|
||||
{ "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] }
|
||||
} <commands> %
|
||||
|
||||
[ word-action ] \ word class-operations modify-listener-operations %
|
||||
[ selected-word ] string class-operations modify-listener-operations %
|
||||
[ quot-action ] quotation class-operations modify-listener-operations %
|
||||
|
||||
{
|
||||
"Listener"
|
||||
{ "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] }
|
||||
{ "Clear output" T{ key-down f f "CLEAR" } [ [ clear-output ] swap interactor-call ] }
|
||||
{ "Clear stack" T{ key-down f { C+ } "CLEAR" } [ [ clear ] swap interactor-call ] }
|
||||
} <commands> %
|
||||
] { } make define-commands*
|
||||
|
|
|
|||
Loading…
Reference in New Issue