UI single stepper tool

library/tools/describe.factor

@@ -76,7 +76,7 @@ DEFER: describe
 
 : describe ( object -- ) dup summary print sheet sheet. ;
 
-: stack. ( seq -- seq ) <reversed> >array describe ;
+: stack. ( seq -- seq ) <reversed> >array sheet sheet. ;
 
 : .s datastack stack. ;
 : .r retainstack stack. ;

library/tools/interpreter.factor

@@ -29,6 +29,9 @@ SYMBOL: callframe
 SYMBOL: callframe-scan
 SYMBOL: callframe-end
 
+: meta-callframe ( -- seq )
+    { callframe callframe-scan callframe-end } [ get ] map ;
+
 ! Callframe.
 : up ( -- )
     pop-c callframe-end set

library/tools/walker.factor

@@ -9,10 +9,7 @@ vectors words ;
 
 : &r ( -- ) meta-r get stack. ;
 
-: meta-c*
-    [
-        meta-c get % { callframe callframe-scan callframe-end } [ get , ] each
-    ] { } make ;
+: meta-c* ( -- seq ) meta-c get meta-callframe append ;
 
 : &c ( -- ) meta-c* callstack. ;
 
@@ -42,5 +39,5 @@ vectors words ;
 : walk ( quot -- )
     continuation [
         set-meta-interp pop-d drop (meta-call)
-        set-walk-hooks walk-banner listener end-walk
+        set-walk-hooks walk-banner (listener) end-walk
     ] with-scope ;

library/ui/tools/listener.factor

@@ -3,52 +3,40 @@
 IN: gadgets-listener
 USING: arrays gadgets gadgets-editors gadgets-frames
 gadgets-labels gadgets-panes gadgets-presentations
-gadgets-scrolling gadgets-theme generic hashtables inspector io
-jedit kernel listener math models namespaces parser prettyprint
-sequences styles threads words ;
+gadgets-scrolling gadgets-theme gadgets-tiles gadgets-tracks
+generic hashtables inspector io jedit kernel listener math
+models namespaces parser prettyprint sequences shells styles
+threads words ;
 
 TUPLE: listener-gadget pane stack ;
 
-: usable-words ( -- words )
-    use get hash-concat hash-values ;
-
-: word-completion ( pane -- )
-    usable-words swap pane-input set-possibilities ;
-
-: show-stack ( seq pack -- )
-    dup clear-gadget [
-        dup empty? [
-            "Empty stack" write drop
-        ] [
-            "Stack top: " write <reversed>
-            [ [ unparse-short ] keep write-object bl ] each bl
-        ] if
-    ] with-stream* ;
-
 : ui-listener-hook ( listener -- )
-    [
-        >r datastack-hook get call r>
-        listener-gadget-stack show-stack
-    ] keep
-    listener-gadget-pane word-completion ;
+    >r datastack-hook get call r>
+    listener-gadget-stack set-model ;
 
 : listener-thread ( listener -- )
     dup listener-gadget-pane [
-        [ ui-listener-hook ] curry listener-hook set
-        print-banner listener
+        [ ui-listener-hook ] curry listener-hook set tty
     ] with-stream* ;
 
-: <stack-bar> ( -- gadget ) <shelf> dup highlight-theme ;
-
 : start-listener ( listener -- )
     [ >r clear r> init-namespaces listener-thread ] in-thread
     drop ;
 
+: <pane-tile> ( model quot title -- gadget )
+    >r <pane-control> <scroller> r> f <tile> ;
+
+: <stack-tile> ( model title -- gadget )
+    [ stack. ] swap <pane-tile> ;
+
+: <stack-display> ( -- gadget )
+    gadget get listener-gadget-stack "Stack" <stack-tile> ;
+
 C: listener-gadget ( -- gadget )
-    {
-        { [ <stack-bar> ] set-listener-gadget-stack f @top }
-        { [ <input-pane> ] set-listener-gadget-pane [ <scroller>  ] @center }
-    } make-frame* dup start-listener ;
+    f <model> over set-listener-gadget-stack {
+        { [ <input-pane> ] set-listener-gadget-pane [ <scroller> ] 5/6 }
+        { [ <stack-display> ] f f 1/6 }
+    } { 0 1 } make-track* dup start-listener ;
 
 M: listener-gadget pref-dim*
     delegate pref-dim* { 600 600 } vmax ;

library/ui/tools/walker.factor

@@ -0,0 +1,106 @@
+! 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-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"   <stack-tile> ] f f 1/3 }
+        { [ "Retain stack" <stack-tile> ] f f 1/3 }
+        { [ [ callstack. ] "Call stack" <pane-tile> ] f f 1/3 }
+    } { 1 0 } make-track* ;
+
+TUPLE: walker-track pane ;
+
+: <quotation-display> ( quot -- gadget )
+    [ [ first2 callframe. ] when* ]
+    "Current quotation" <pane-tile> ;
+
+C: walker-track ( cs rs ds quot -- gadget )
+    {
+        { [ <quotation-display> ] f f 1/6 }
+        { [ <stack-track> ] f f 1/6 }
+        { [ <input-pane> ] set-walker-track-pane [ <scroller> ] 2/3 }
+    } { 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-command ( button word -- )
+    unit swap find-walker-gadget walker-gadget-pane pane-call ;
+
+: step ( -- ) next do-1 ;
+
+: into ( -- ) next do ;
+
+: end ( -- ) save-callframe meta-interp continue ;
+
+: <walker-toolbar> ( -- gadget )
+    {
+        { "Step over" step }
+        { "Step into" into }
+        { "Continue" end }
+    } [
+        [
+            first2 [ walker-command ] curry <bevel-button> ,
+        ] each
+    ] make-toolbar ;
+
+: init-walker-models ( walker -- )
+    f <model> over set-walker-gadget-ds
+    f <model> over set-walker-gadget-rs
+    f <model> over set-walker-gadget-cs
+    f <model> 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 ;
+
+C: walker-gadget ( -- gadget )
+    dup init-walker-models {
+        { [ <walker-toolbar> ] f f @top }
+        { [ walker-models <walker-track> ] set-walker-gadget-track f @center }
+    } make-frame* ;
+
+M: walker-gadget gadget-title
+    drop "Single stepper" <model> ;
+
+M: walker-gadget pref-dim*
+    delegate pref-dim* { 600 600 } vmax ;
+
+M: walker-gadget focusable-child* ( listener -- gadget )
+    walker-gadget-pane ;
+
+: walker ( quot continuation -- )
+    "walk " listener-prompt set
+    set-meta-interp pop-d drop (meta-call)
+    clear (listener) end ;
+
+: walker-thread ( quot continuation walker -- )
+    dup walker-gadget-pane [
+        [ walker-listener-hook ] curry listener-hook set
+        walker
+    ] with-pane ;
+
+: start-walker ( quot continuation walker -- )
+    [ init-namespaces walker-thread ] in-thread 3drop ;
+
+: walk ( quot -- )
+    continuation <walker-gadget> dup open-window
+    start-walker ;