diff --git a/library/ui/tools/walker.factor b/library/ui/tools/walker.factor new file mode 100644 index 0000000000..069355c011 --- /dev/null +++ b/library/ui/tools/walker.factor @@ -0,0 +1,120 @@ +! Copyright (C) 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: gadgets-walker +USING: gadgets gadgets-buttons gadgets-frames gadgets-listener +gadgets-panes gadgets-scrolling gadgets-text gadgets-tiles +gadgets-tracks generic inspector interpreter io kernel listener +math models namespaces sequences shells threads ; + +TUPLE: stack-track ; + +C: stack-track ( cs rs ds -- gadget ) + { + { [ "Data stack" ] f f 1/3 } + { [ "Retain stack" ] f f 1/3 } + { [ [ callstack. ] "Call stack" ] f f 1/3 } + } { 1 0 } make-track* ; + +TUPLE: walker-track pane input ; + +: ( quot -- gadget ) + [ [ first2 callframe. ] when* ] ; + +: ( -- gadget ) + gadget get walker-track-pane ; + +C: walker-track ( cs rs ds quot -- gadget ) + { + { [ ] f f 1/12 } + { [ ] f f 3/12 } + { [ ] set-walker-track-pane [ ] 1/2 } + { [ ] set-walker-track-input [ ] 1/6 } + } { 0 1 } make-track* ; + +TUPLE: walker-gadget track ds rs cs quot ; + +: find-walker-gadget [ walker-gadget? ] find-parent ; + +: walker-gadget-pane walker-gadget-track walker-track-pane ; + +: walker-gadget-input walker-gadget-track walker-track-input ; + +: walker-command ( button word -- ) + unit swap find-walker-gadget walker-gadget-input + interactor-call ; + +: ( -- gadget ) + { + { "Step" step } + { "Step in" into } + { "Step out" end-quot } + { "Step all" end } + } [ + [ + first2 [ walker-command ] curry , + ] each + ] make-toolbar ; + +: init-walker-models ( walker -- ) + f over set-walker-gadget-ds + f over set-walker-gadget-rs + f over set-walker-gadget-cs + f swap set-walker-gadget-quot ; + +: walker-models ( -- cs rs ds quot ) + gadget get walker-gadget-cs + gadget get walker-gadget-rs + gadget get walker-gadget-ds + gadget get walker-gadget-quot ; + +: walker-listener-hook ( walker -- ) + meta-d get over walker-gadget-ds set-model + meta-r get over walker-gadget-rs set-model + meta-c get over walker-gadget-cs set-model + meta-callframe swap walker-gadget-quot set-model ; + +: walker-stream ( walker -- stream ) + dup walker-gadget-input swap walker-gadget-pane + ; + +M: walker-gadget gadget-title + drop "Single stepper" ; + +M: walker-gadget pref-dim* + delegate pref-dim* { 600 600 } vmax ; + +M: walker-gadget focusable-child* ( listener -- gadget ) + walker-gadget-input ; + +: init-walker ( -- ) + [ walker-listener-hook ] curry listener-hook set + "walk " listener-prompt set + continuation + V{ } clone over set-continuation-call + V{ } clone over set-continuation-data + set-meta-interp + [ ] (meta-call) ; + +: walker-thread ( walker -- ) + [ + init-namespaces + dup walker-stream [ + [ init-walker clear ] listener + ] with-stream* + ] in-thread drop ; + +C: walker-gadget ( -- gadget ) + dup init-walker-models { + { [ ] f f @top } + { [ walker-models ] set-walker-gadget-track f @center } + } make-frame* dup walker-thread ; + +: (walk) ( quot walker -- ) + >r [ meta-call ] curry r> + walker-gadget-input interactor-call ; + +: walker-tool + [ walker-gadget? ] [ ] [ (walk) ] ; + +: walk ( quot -- ) + walker-tool call-tool ;