Close error popup after choosing a restart, remove modify-listener-operations and associated cruft

TODO.txt

@@ -1,11 +1,10 @@
 + 0.87:
 
-- menu Command: quots look dumb
+- ui operations: restarts are broken
-- no need for modify-listener-operation!
 - command buttons: indicate shortcuts
-- hide popup after a restart
 - http://paste.lisp.org/display/30426
 - update ui docs
+- error window, why so small?
 
 + 0.88:
 
@@ -49,6 +48,7 @@
 
 + ui:
 
+- browser tool: dropdown menu button for definition operations
 - copying pane output
 - how do we refer to command shortcuts in the docs?
 - editor:

core/ui/commands.factor

@@ -63,20 +63,11 @@ SYMBOL: +keyboard+
 SYMBOL: +primary+
 SYMBOL: +secondary+
 
-TUPLE: operation predicate listener? primary? secondary? ;
+TUPLE: operation predicate primary? secondary? ;
 
 : (command) ( -- command )
     +name+ get +keyboard+ get +quot+ get <command> ;
 
-C: operation ( predicate hash -- operation )
-    swap [
-        (command) over set-delegate
-        +primary+ get over set-operation-primary?
-        +secondary+ get over set-operation-secondary?
-        +listener+ get over set-operation-listener?
-    ] bind
-    [ set-operation-predicate ] keep ;
-
 SYMBOL: operations
 
 : object-operations ( obj -- operations )

core/ui/debugger.factor

@@ -13,8 +13,8 @@ queues sequences test threads help sequences words timers ;
 : <debugger-button>
     [ call-listener drop ] curry <bevel-button> ;
 
-: <restart-list> ( seq -- gadget )
+: <restart-list> ( seq restart-hook -- gadget )
-    [ drop ] [ restart-name ] rot <model> <list> ;
+    [ restart-name ] rot <model> <list> ;
 
 TUPLE: debugger restarts ;
 
@@ -23,7 +23,7 @@ TUPLE: debugger restarts ;
     2array make-pile
     1 over set-pack-fill ;
 
-C: debugger ( error restarts -- gadget )
+C: debugger ( error restarts restart-hook -- gadget )
     {
         {
             [ gadget get { debugger } <toolbar> ]
@@ -51,7 +51,8 @@ debugger "toolbar" {
 ] map define-commands
 
 : debugger-window ( error restarts -- )
-    restarts get <debugger> "Error" open-titled-window ;
+    restarts get [ drop ] <debugger>
+    "Error" open-titled-window ;
 
 : ui-try ( quot -- )
     [ debugger-window ] recover ;

core/ui/tools/operations.factor

@@ -9,20 +9,23 @@ test tools words generic models io modules errors ;
 
 V{ } clone operations set-global
 
+: handle-listener-operation
+    +listener+ get [
+        +quot+ [ [ curry call-listener ] curry ] change
+    ] when ;
+
+C: operation ( predicate hash -- operation )
+    swap clone [
+        handle-listener-operation
+        (command) over set-delegate
+        +primary+ get over set-operation-primary?
+        +secondary+ get over set-operation-secondary?
+    ] bind
+    [ set-operation-predicate ] keep ;
+
 : define-operation ( class props -- )
     <operation> operations get push-new ;
 
-M: operation invoke-command ( target operation -- )
-    dup command-quot swap operation-listener?
-    [ curry call-listener ] [ call ] if ;
-
-: modify-listener-operation ( quot operation -- operation )
-    clone t over set-operation-listener?
-    modify-command ;
-
-: modify-listener-operations ( operations quot -- operations )
-    swap [ modify-listener-operation ] map-with ;
-
 ! Objects
 [ drop t ] H{
     { +primary+ t }
@@ -310,12 +313,12 @@ M: operation invoke-command ( target operation -- )
 
 interactor "words"
 { word compound } [ class-operations ] map concat
-[ word-action ] modify-listener-operations
+[ word-action ] modify-commands
 define-commands
 
 interactor "quotations"
 quotation class-operations
-[ quot-action ] modify-listener-operations
+[ quot-action ] modify-commands
 define-commands
 
 help-gadget "toolbar" {

core/ui/tools/workspace.factor

@@ -95,8 +95,8 @@ M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
     swap popup-loc swap set-rect-loc ;
 
 : debugger-popup ( workspace -- )
-    error get restarts get <debugger>
+    error get restarts get [ find-workspace hide-popup ]
-    "Error" show-titled-popup ;
+    <debugger> "Error" show-titled-popup ;
 
 C: workspace ( -- workspace )
     [ debugger-popup ] over set-workspace-error-hook