UI debugger, first cut

2006-11-30 07:15:42 +00:00 · 2006-11-30 07:15:42 +00:00 · 3ac7498862
parent 18e0be59e0
commit 3ac7498862
14 changed files with 131 additions and 64 deletions
--- a/TODO.txt
+++ b/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
--- a/core/errors.factor
+++ b/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-restarts [ swap add ] map-with append ;
+    [ condition-continuation ] keep
+    condition-restarts [ first2 rot <restart> ] map-with
+    append ;

 PREDICATE: array kernel-error ( obj -- ? )
    dup first \ kernel-error eq? swap second 0 18 between? and ;
--- a/core/io/stdio.factor
+++ b/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) ;
-
-: print-quot ( string quot -- )
-    quotation (print-input/quot) ;
+    <input> presented associate
+    [ H{ { font-style bold } } format ] with-nesting
+    terpri ;
--- a/core/tools/debugger.factor
+++ b/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
-    f restarts set-global
-    first3 continue-with ;
+    restarts get-global nth f restarts set-global restart ;

 : :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 ] curry print-quot ;
+    [ # " :res  " % restart-name % ] "" make print ;

 : 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
-    ":s    - data stack at exception time" [ :s ] print-quot
-    ":r    - retain stack at exception time" [ :r ] print-quot
-    ":c    - call stack at exception time" [ :c ] print-quot
+    ":help - documentation for this error" print
+    ":s    - data stack at exception time" print
+    ":r    - retain stack at exception time" print
+    ":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 ;
--- a/core/tools/inspector.factor
+++ b/core/tools/inspector.factor
@ -25,8 +25,8 @@ SYMBOL: inspector-stack

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

--- a/core/ui/gadgets/presentations.factor
+++ b/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 ;

--- a/core/ui/load.factor
+++ b/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"
--- a/core/ui/text/interactor.factor
+++ b/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
-    swap interactor-output [ print-error ] with-stream* ;
+    dup parse-error? [ dupd go-to-error ] when
+    interactor-error-hook call ;

 : try-parse ( str interactor -- quot/error/f )
    [
--- a/core/ui/tools/debugger.factor
+++ b/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
--- a/core/ui/tools/listener.factor
+++ b/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
--- a/core/ui/tools/operations.factor
+++ b/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 }
--- a/core/ui/tools/search.factor
+++ b/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 ;

--- a/core/ui/tools/tools.factor
+++ b/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 ;

--- a/core/ui/tools/workspace.factor
+++ b/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