UI debugger, first cut

TODO.txt

@@ -1,22 +1,24 @@
 + 0.87:
 
 - parse errors should be shown in a popup
-- growable data heap
+  - menu Command: quots look dumb
+  - no need for modify-listener-operation!
+  - command buttons: indicate shortcuts
+- http://paste.lisp.org/display/30426
+- update ui docs
 
++ 0.88:
+
+- growable data heap
 - variable width word wrap
 - graphical crossref tool
-- http://paste.lisp.org/display/30426
 - compiled call traces:
   - should be independent of whenever the runtime was built with
     -fomit-frame-pointer or not
   - doesn't show #labels
   - we don't know if signal handlers run with the same stack or not
-
-+ 0.88:
-
 - use crc32 instead of modification date in reload-modules
 - models: don't do redundant work
-- menu Command: quots look dumb
 - top level window positioning on ms windows
 - crashes:
   - callback scheduling issue
@@ -31,6 +33,7 @@
   - available-modules
   - :trace
   - string-lines
+  - md5, crc32
 - auto-update browser and help when sources reload
 - mac intel: struct returns from objc methods
 - new windows don't always have focus, eg focus follows mouse

core/errors.factor

@@ -30,16 +30,21 @@ SYMBOL: restarts
     [ >c drop call c> drop ]
     [ rot drop swap call ] ifcc ; inline
 
-TUPLE: condition restarts cc ;
+TUPLE: condition restarts continuation ;
 
 C: condition ( error restarts cc -- condition )
-    [ set-condition-cc ] keep
+    [ set-condition-continuation ] keep
     [ set-condition-restarts ] keep
     [ set-delegate ] keep ;
 
 : condition ( error restarts -- restart )
     [ <condition> throw ] callcc1 2nip ;
 
+TUPLE: restart name obj continuation ;
+
+: restart ( restart -- )
+    dup restart-obj swap restart-continuation continue-with ;
+
 GENERIC: compute-restarts ( error -- seq )
 
 M: object compute-restarts drop { } ;
@@ -48,8 +53,9 @@ M: tuple compute-restarts delegate compute-restarts ;
 
 M: condition compute-restarts
     [ delegate compute-restarts ] keep
-    [ condition-cc ] keep
+    [ condition-continuation ] keep
-    condition-restarts [ swap add ] map-with append ;
+    condition-restarts [ first2 rot <restart> ] map-with
+    append ;
 
 PREDICATE: array kernel-error ( obj -- ? )
     dup first \ kernel-error eq? swap second 0 18 between? and ;

core/io/stdio.factor

@@ -46,12 +46,7 @@ SYMBOL: stdio
 : write-outliner ( str obj content -- )
     outline associate [ write-object ] with-nesting ;
 
-: (print-input/quot)
-    associate [ H{ { font-style bold } } format ] with-nesting
-    terpri ;
-
 : print-input ( string input -- )
-    <input> presented (print-input/quot) ;
+    <input> presented associate
-
+    [ H{ { font-style bold } } format ] with-nesting
-: print-quot ( string quot -- )
+    terpri ;
-    quotation (print-input/quot) ;

core/tools/debugger.factor

@@ -78,12 +78,10 @@ M: string error. print ;
     error-continuation get continuation-name hash-stack ;
 
 : :res ( n -- )
-    restarts get-global nth
+    restarts get-global nth f restarts set-global restart ;
-    f restarts set-global
-    first3 continue-with ;
 
 : :edit ( -- )
-    error get delegates [ parse-error-file ] find nip [
+    error get delegates [ parse-error? ] find-last nip [
         dup parse-error-file ?resource-path
         swap parse-error-line edit-location
     ] when* ;
@@ -104,8 +102,7 @@ M: string error. print ;
     } cond ;
 
 : restart. ( restart n -- )
-    [ [ # " :res  " % first % ] "" make ] keep
+    [ # " :res  " % restart-name % ] "" make print ;
-    [ :res ] curry print-quot ;
 
 : restarts. ( -- )
     restarts get dup empty? [
@@ -121,13 +118,13 @@ M: string error. print ;
     terpri
     "Debugger commands:" print
     terpri
-    ":help - documentation for this error" [ :help ] print-quot
+    ":help - documentation for this error" print
-    ":s    - data stack at exception time" [ :s ] print-quot
+    ":s    - data stack at exception time" print
-    ":r    - retain stack at exception time" [ :r ] print-quot
+    ":r    - retain stack at exception time" print
-    ":c    - call stack at exception time" [ :c ] print-quot
+    ":c    - call stack at exception time" print
 
     error get [ parse-error? ] is? [
-        ":edit - jump to source location" [ :edit ] print-quot
+        ":edit - jump to source location" print
     ] when
 
     ":get  ( var -- value ) accesses variables at time of the error" print
@@ -142,4 +139,7 @@ M: string error. print ;
         "Error in print-error!" print
     ] recover drop ;
 
-: try ( quot -- ) [ print-error ] recover ;
+SYMBOL: error-hook
+
+: try ( quot -- )
+    [ error-hook get [ call ] [ print-error ] ?if ] recover ;

core/tools/inspector.factor

@@ -25,8 +25,8 @@ SYMBOL: inspector-stack
 
 : inspector-help ( -- )
     "Object inspector." print
-    "up -- return to previous object" [ up ] print-quot
+    "up -- return to previous object" print
-    "me ( -- obj ) push this object" [ me ] print-quot
+    "me ( -- obj ) push this object" print
     "go ( n -- ) inspect nth slot" print
     terpri ;
 

core/ui/gadgets/presentations.factor

@@ -81,9 +81,6 @@ presentation H{
         [ presentation-object summary ] [ "" ] if*
     ] <filter> <label-control> dup reverse-video-theme ;
 
-: <listener-button> ( gadget quot -- button )
-    [ call-listener drop ] curry <roll-button> ;
-
 ! Character styles
 
 : apply-style ( style gadget key quot -- style gadget )
@@ -106,16 +103,12 @@ presentation H{
 : apply-presentation-style ( style gadget -- style gadget )
     presented [ <presentation> ] apply-style ;
 
-: apply-quotation-style ( style gadget -- style gadget )
-    quotation [ <listener-button> ] apply-style ;
-
 : <styled-label> ( style text -- gadget )
     <label>
     apply-foreground-style
     apply-background-style
     apply-font-style
     apply-presentation-style
-    apply-quotation-style
     nip ;
 
 ! Paragraph styles
@@ -148,7 +141,6 @@ presentation H{
     apply-border-color-style
     apply-page-color-style
     apply-presentation-style
-    apply-quotation-style
     apply-outliner-style
     nip ;
 

core/ui/load.factor

@@ -40,6 +40,7 @@ PROVIDE: core/ui
     "text/interactor.factor"
     "ui.factor"
     "tools/tools.factor"
+    "tools/debugger.factor"
     "tools/messages.factor"
     "tools/listener.factor"
     "tools/walker.factor"

core/ui/text/interactor.factor

@@ -9,7 +9,7 @@ math listener models errors ;
 TUPLE: interactor
 history output
 continuation quot busy?
-use in ;
+use in error-hook ;
 
 C: interactor ( output -- gadget )
     [ set-interactor-output ] keep
@@ -66,19 +66,21 @@ M: interactor stream-read
 
 : save-in/use ( interactor -- )
     use get over set-interactor-use
-    in get swap set-interactor-in ;
+    in get over set-interactor-in
+    error-hook get swap set-interactor-error-hook ;
 
 : restore-in/use ( interactor -- )
     dup interactor-use use set
-    interactor-in in set ;
+    dup interactor-in in set
+    interactor-error-hook error-hook set ;
 
 : go-to-error ( interactor error -- )
     dup parse-error-line 1- swap parse-error-col 2array
     over editor-caret set-model mark>caret ;
 
 : handle-parse-error ( interactor error -- )
-    dup parse-error? [ 2dup go-to-error delegate ] when
+    dup parse-error? [ dupd go-to-error ] when
-    swap interactor-output [ print-error ] with-stream* ;
+    interactor-error-hook call ;
 
 : try-parse ( str interactor -- quot/error/f )
     [

core/ui/tools/debugger.factor

@@ -0,0 +1,46 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-debugger
+USING: errors sequences gadgets gadgets-buttons gadgets-listener
+gadgets-panes gadgets-lists gadgets-scrolling gadgets-theme
+kernel models arrays namespaces ;
+
+: <debugger-button>
+    [ call-listener drop ] curry <bevel-button> ;
+
+: <restart-list> ( seq -- gadget )
+    [ drop ] [ restart-name ] rot <model> <list> ;
+
+TUPLE: debugger restarts ;
+
+: <debugger-display> ( error restart-list -- gadget )
+    >r [ error. ] make-pane r>
+    2array make-pile
+    1 over set-pack-fill ;
+
+C: debugger ( error restarts -- gadget )
+    {
+        {
+            [ gadget get { debugger } <toolbar> ]
+            f f @top
+        }
+        {
+            [ <restart-list> ]
+            set-debugger-restarts
+            [ <debugger-display> <scroller> ]
+            @center
+        }
+    } make-frame* dup popup-theme ;
+
+M: debugger focusable-child*
+    debugger-restarts ;
+
+debugger "toolbar" {
+    { "Data stack" T{ key-down f f "s" } [ :s ] }
+    { "Retain stack" T{ key-down f f "r" } [ :r ] }
+    { "Call stack" T{ key-down f f "c" } [ :c ] }
+    { "Help" T{ key-down f f "h" } [ :help ] }
+    { "Edit" T{ key-down f f "e" } [ :edit ] }
+} [
+    first3 [ call-listener drop ] curry 3array
+] map define-commands

core/ui/tools/listener.factor

@@ -6,7 +6,7 @@ gadgets-panes gadgets-scrolling gadgets-text
 gadgets-theme gadgets-tracks gadgets-workspace
 generic hashtables tools io kernel listener math models
 namespaces parser prettyprint sequences shells strings styles
-threads words definitions help ;
+threads words definitions help errors ;
 
 TUPLE: listener-gadget input output stack use ;
 
@@ -14,6 +14,9 @@ TUPLE: listener-gadget input output stack use ;
     use get over set-listener-gadget-use
     >r datastack r> listener-gadget-stack set-model ;
 
+: ui-error-hook ( listener -- )
+    find-workspace dup workspace-error-hook call ;
+
 : listener-stream ( listener -- stream )
     dup listener-gadget-input
     swap listener-gadget-output <pane-stream>
@@ -37,7 +40,9 @@ TUPLE: listener-gadget input output stack use ;
 
 : listener-thread ( listener -- )
     dup listener-stream [
+        dup
         [ ui-listener-hook ] curry listener-hook set
+        [ ui-error-hook ] curry error-hook set
         find-messages batch-errors set
         welcome.
         listener

core/ui/tools/operations.factor

@@ -5,7 +5,7 @@ USING: definitions gadgets gadgets-browser gadgets-dataflow
 gadgets-help gadgets-listener gadgets-search gadgets-text
 gadgets-workspace hashtables help inference kernel namespaces
 parser prettyprint scratchpad sequences strings styles syntax
-test tools words generic models io modules ;
+test tools words generic models io modules errors ;
 
 V{ } clone operations set-global
 
@@ -51,6 +51,15 @@ M: operation invoke-command ( target operation -- )
     { +quot+ [ listener-gadget call-tool ] }
 } define-operation
 
+! Restart
+[ restart? ] H{
+    { +primary+ t }
+    { +secondary+ t }
+    { +name+ "Restart" }
+    { +quot+ [ restart ] }
+    { +listener+ t }
+} define-operation
+
 ! Pathnames
 [ pathname? ] H{
     { +primary+ t }

core/ui/tools/search.factor

@@ -109,11 +109,6 @@ M: live-search focusable-child* live-search-field ;
     [ input-string ]
     <live-search> ;
 
-: show-titled-popup ( workspace gadget title -- )
-    [ find-workspace hide-popup ] <closable-gadget>
-    [ popup-theme ] keep
-    swap show-popup ;
-
 : workspace-listener ( workspace -- listener )
     listener-gadget swap find-tool tool-gadget nip ;
 

core/ui/tools/tools.factor

@@ -20,7 +20,7 @@ GENERIC: tool-help ( tool -- topic )
 
 M: gadget tool-help drop f ;
 
-TUPLE: workspace book popup ;
+TUPLE: workspace book popup error-hook ;
 
 : find-workspace [ workspace? ] find-parent ;
 

core/ui/tools/workspace.factor

@@ -4,9 +4,10 @@ IN: gadgets-workspace
 USING: help arrays compiler gadgets gadgets-books
 gadgets-browser gadgets-buttons gadgets-dataflow gadgets-help
 gadgets-listener gadgets-presentations gadgets-walker
-gadgets-workspace generic kernel math modules scratchpad
+gadgets-debugger generic kernel math modules scratchpad
 sequences syntax words io namespaces hashtables
-gadgets-scrolling gadgets-panes gadgets-messages ;
+gadgets-scrolling gadgets-panes gadgets-messages gadgets-theme
+errors ;
 
 C: tool ( gadget -- tool )
     {
@@ -61,13 +62,6 @@ tool "toolbar" {
 : <workspace-book> ( -- gadget )
     workspace-tabs 1 <column> [ execute <tool> ] map <book> ;
 
-C: workspace ( -- workspace )
-    {
-        { [ <workspace-book> ] set-workspace-book f @center }
-        { [ gadget get <workspace-tabs> ] f f @top }
-        { [ gadget get { workspace } <toolbar> ] f f @bottom }
-    } make-frame* ;
-
 M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
 
 : init-status ( world -- )
@@ -79,9 +73,16 @@ M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
     request-focus ;
 
 : show-popup ( gadget workspace -- )
-    dup hide-popup 2dup set-workspace-popup dupd add-gadget
+    dup hide-popup
+    2dup set-workspace-popup
+    dupd add-gadget
+    dup popup-theme
     request-focus ;
 
+: show-titled-popup ( workspace gadget title -- )
+    [ find-workspace hide-popup ] <closable-gadget>
+    swap show-popup ;
+
 : popup-dim ( workspace -- dim )
     rect-dim first2 4 /i 2array ;
 
@@ -94,6 +95,18 @@ M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
     over popup-dim over set-gadget-dim
     swap popup-loc swap set-rect-loc ;
 
+: debugger-popup ( workspace -- )
+    error get restarts get <debugger>
+    "Error" show-titled-popup ;
+
+C: workspace ( -- workspace )
+    [ debugger-popup ] over set-workspace-error-hook
+    {
+        { [ <workspace-book> ] set-workspace-book f @center }
+        { [ gadget get <workspace-tabs> ] f f @top }
+        { [ gadget get { workspace } <toolbar> ] f f @bottom }
+    } make-frame* ;
+
 M: workspace layout*
     dup delegate layout*
     dup workspace-book swap workspace-popup dup