More robust UI error handling

TODO.FACTOR.txt

@@ -16,6 +16,7 @@
 
 + ui:
 
+- shift modifier not delivered
 - x11 copy to clipboard
 - finish gui stepper
 - windows are not updated while resizing

library/ui/cocoa/application-utils.factor

@@ -35,7 +35,7 @@ objc-classes sequences threads ;
     dup do-event [ do-events ] [ drop ] if ;
 
 : event-loop ( -- )
-    [ NSApp do-events ui-step ] with-autorelease-pool
+    [ [ NSApp do-events ui-step ] ui-try ] with-autorelease-pool
     event-loop ;
 
 : add-observer ( observer selector name object -- )

library/ui/cocoa/view-utils.factor

@@ -99,79 +99,83 @@ opengl sequences ;
     }
     
     { "mouseEntered:" "void" { "id" "SEL" "id" }
-        [ nip send-mouse-moved ]
+        [ [ nip send-mouse-moved ] ui-try ]
     }
     
     { "mouseExited:" "void" { "id" "SEL" "id" }
-        [ 3drop forget-rollover ]
+        [ [ 3drop forget-rollover ] ui-try ]
     }
     
     { "mouseMoved:" "void" { "id" "SEL" "id" }
-        [ nip send-mouse-moved ]
+        [ [ nip send-mouse-moved ] ui-try ]
     }
     
     { "mouseDragged:" "void" { "id" "SEL" "id" }
-        [ nip send-mouse-moved ]
+        [ [ nip send-mouse-moved ] ui-try ]
     }
     
     { "rightMouseDragged:" "void" { "id" "SEL" "id" }
-        [ nip send-mouse-moved ]
+        [ [ nip send-mouse-moved ] ui-try ]
     }
     
     { "otherMouseDragged:" "void" { "id" "SEL" "id" }
-        [ nip send-mouse-moved ]
+        [ [ nip send-mouse-moved ] ui-try ]
     }
     
     { "mouseDown:" "void" { "id" "SEL" "id" }
-        [ nip send-button-down$ ]
+        [ [ nip send-button-down$ ] ui-try ]
     }
     
     { "mouseUp:" "void" { "id" "SEL" "id" }
-        [ nip send-button-up$ ]
+        [ [ nip send-button-up$ ] ui-try ]
     }
     
     { "rightMouseDown:" "void" { "id" "SEL" "id" }
-        [ nip send-button-down$ ]
+        [ [ nip send-button-down$ ] ui-try ]
     }
     
     { "rightMouseUp:" "void" { "id" "SEL" "id" }
-        [ nip send-button-up$ ]
+        [ [ nip send-button-up$ ] ui-try ]
     }
     
     { "otherMouseDown:" "void" { "id" "SEL" "id" }
-        [ nip send-button-down$ ]
+        [ [ nip send-button-down$ ] ui-try ]
     }
     
     { "otherMouseUp:" "void" { "id" "SEL" "id" }
-        [ nip send-button-up$ ]
+        [ [ nip send-button-up$ ] ui-try ]
     }
     
     { "scrollWheel:" "void" { "id" "SEL" "id" }
-        [ nip send-wheel$ ]
+        [ [ nip send-wheel$ ] ui-try ]
     }
     
     { "keyDown:" "void" { "id" "SEL" "id" }
-        [ nip send-key-down-event ]
+        [ [ nip send-key-down-event ] ui-try ]
     }
     
     { "keyUp:" "void" { "id" "SEL" "id" }
-        [ nip send-key-up-event ]
+        [ [ nip send-key-up-event ] ui-try ]
     }
 
     { "cut:" "id" { "id" "SEL" "id" }
-        [ nip T{ cut-action } send-action ]
+        [ [ nip T{ cut-action } send-action ] ui-try ]
     }
 
     { "copy:" "id" { "id" "SEL" "id" }
-        [ nip T{ copy-action } send-action ]
+        [ [ nip T{ copy-action } send-action ] ui-try ]
     }
 
     { "paste:" "id" { "id" "SEL" "id" }
-        [ nip T{ paste-action } send-action ]
+        [ [ nip T{ paste-action } send-action ] ui-try ]
     }
 
     { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
-        [ 2drop dup view-dim swap window set-gadget-dim ]
+        [
+            [
+                2drop dup view-dim swap window set-gadget-dim
+            ] ui-try
+        ]
     }
     
     { "acceptsFirstResponder" "bool" { "id" "SEL" }

library/ui/paint.factor

@@ -72,14 +72,34 @@ DEFER: draw-gadget
         { [ t ] [ [ (draw-gadget) ] with-clipping ] }
     } cond ;
 
-: draw-world ( world -- )
-    [
+: (draw-world) ( world -- )
     dup world-handle [
-            dup rect-dim init-gl
-            dup world set
-            draw-gadget
-        ] with-gl-context
-    ] with-scope ;
+        dup rect-dim init-gl draw-gadget
+    ] with-gl-context ;
+
+TUPLE: world-error world ;
+
+C: world-error ( error world -- error )
+    [ set-world-error-world ] keep
+    [ set-delegate ] keep ;
+
+M: world-error error. ( world-error -- )
+    "An error occurred while drawing the world " write
+    dup world-error-world pprint-short "." print
+    "This world has been deactivated to prevent cascading errors." print
+    delegate error. ;
+
+: draw-world ( world -- )
+    dup world-active? [
+        [
+            dup world set [
+                dup (draw-world)
+            ] [
+                over <world-error> error-window
+                f over set-world-active?
+            ] recover
+        ] with-scope
+    ] when drop ;
 
 ! Pen paint properties
 M: f draw-interior 2drop ;

library/ui/ui.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets
-USING: arrays gadgets gadgets-frames gadgets-grids
-gadgets-labels gadgets-theme gadgets-viewports hashtables kernel
-math models namespaces queues sequences threads ;
+USING: arrays errors gadgets gadgets-frames gadgets-grids
+gadgets-labels gadgets-panes gadgets-theme gadgets-viewports
+hashtables kernel math models namespaces queues sequences
+threads ;
 
 ! Assoc mapping aliens to gadgets
 SYMBOL: windows
@@ -137,6 +138,12 @@ C: titled-gadget ( gadget title -- )
 : make-toolbar ( quot -- gadget )
     { } make make-shelf dup highlight-theme ; inline
 
+: error-window ( error -- )
+    [ print-error ] make-pane "Error" open-titled-window ;
+
+: ui-try ( quot -- )
+    [ error-window ] recover ;
+
 IN: shells
 
 DEFER: ui

library/ui/world.factor

@@ -14,7 +14,13 @@ kernel math models namespaces opengl sequences ;
 !   we don't store this in the world's rect-loc, since the
 !   co-ordinate system might be different, and generally the
 !   UI code assumes that everything starts at { 0 0 }.
-TUPLE: world gadget title status focus focused? fonts handle loc ;
+TUPLE: world
+active?
+gadget
+title status
+focus focused?
+fonts handle
+loc ;
 
 : free-fonts ( world -- )
     dup world-handle select-gl-context
@@ -27,6 +33,7 @@ C: world ( gadget -- world )
     [ >r dup gadget-title r> set-world-title ] keep
     { { f set-world-gadget f @center } } make-frame*
     t over set-gadget-root?
+    t over set-world-active?
     H{ } clone over set-world-fonts
     { 0 0 } over set-world-loc
     dup world-gadget request-focus ;

library/ui/x11/events.factor

@@ -70,11 +70,9 @@ GENERIC: client-event ( event window -- )
         { [ t ] [ 3drop ] }
     } cond ;
 
-: event-loop ( -- )
-    windows get empty? [
+: do-events ( -- )
     wait-event dup XAnyEvent-window window dup
-        [ handle-event ] [ 2drop ] if event-loop
-    ] unless ;
+    [ handle-event ] [ 2drop ] if ;
 
 : char-array>string ( n <char-array> -- string )
     swap >string [ swap char-nth ] map-with ;

library/ui/x11/ui.factor

@@ -126,6 +126,11 @@ M: world client-event ( event world -- )
         [ register-window ] keep r> 2array
     ] keep set-world-handle ;
 
+: event-loop ( -- )
+    windows get empty? [
+        [ do-events ] ui-try event-loop
+    ] unless ;
+
 IN: gadgets
 
 : set-title ( string world -- )