diff --git a/TODO.txt b/TODO.txt index 36710fe818..2a47177a2c 100644 --- a/TODO.txt +++ b/TODO.txt @@ -1,11 +1,10 @@ + 0.87: -- menu Command: quots look dumb -- no need for modify-listener-operation! +- ui operations: restarts are broken - 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: diff --git a/core/ui/commands.factor b/core/ui/commands.factor index cc5f9a5296..0bb8204df3 100644 --- a/core/ui/commands.factor +++ b/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 ; -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 ) diff --git a/core/ui/debugger.factor b/core/ui/debugger.factor index efd8b9899e..ee5633e72b 100644 --- a/core/ui/debugger.factor +++ b/core/ui/debugger.factor @@ -13,8 +13,8 @@ queues sequences test threads help sequences words timers ; : [ call-listener drop ] curry ; -: ( seq -- gadget ) - [ drop ] [ restart-name ] rot ; +: ( seq restart-hook -- gadget ) + [ restart-name ] rot ; 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 } ] @@ -51,7 +51,8 @@ debugger "toolbar" { ] map define-commands : debugger-window ( error restarts -- ) - restarts get "Error" open-titled-window ; + restarts get [ drop ] + "Error" open-titled-window ; : ui-try ( quot -- ) [ debugger-window ] recover ; diff --git a/core/ui/tools/operations.factor b/core/ui/tools/operations.factor index abcdf3d8c8..1cc512e80f 100644 --- a/core/ui/tools/operations.factor +++ b/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 -- ) 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" { diff --git a/core/ui/tools/workspace.factor b/core/ui/tools/workspace.factor index a6d78c01ff..399ee1bda5 100644 --- a/core/ui/tools/workspace.factor +++ b/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 - "Error" show-titled-popup ; + error get restarts get [ find-workspace hide-popup ] + "Error" show-titled-popup ; C: workspace ( -- workspace ) [ debugger-popup ] over set-workspace-error-hook