[Fencommits] fenfire-hs: show exceptions in a message dialog

[Tuukka Hastrup]

Thu Mar  1 21:11:16 EET 2007  Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
  * show exceptions in a message dialog
diff -rN -u old-fenfire-hs/Main.hs new-fenfire-hs/Main.hs
--- old-fenfire-hs/Main.hs	2007-03-01 21:11:04.000000000 +0200
+++ new-fenfire-hs/Main.hs	2007-03-01 21:11:05.000000000 +0200
@@ -379,6 +379,11 @@
             item <- actionCreateToolItem action
             toolbarInsert toolbar (castToToolItem item) (-1)
 
+handleException e = do
+    dialog <- makeMessageDialog "Exception in event" (show e)
+    dialogRun dialog
+    widgetHide dialog
+
 
 main :: IO ()
 main = do
@@ -488,7 +493,7 @@
     
     (canvas, updateCanvas, canvasAction) <- 
         vobCanvas stateRef view handleEvent handleAction
-                  stateChanged (fromGtkColor canvasBgColor) 0.5
+                  stateChanged handleException (fromGtkColor canvasBgColor) 0.5
 
     onFocusIn canvas $ \_event -> do 
         modifyIORef stateRef $ \s -> s { fsHasFocus = True }
@@ -677,3 +682,33 @@
         [(stockCancel, ResponseCancel),
          (stockRevertToSaved,ResponseClose)]
         ResponseCancel
+
+makeMessageDialog primary secondary = do
+    dialog <- dialogNew
+    set dialog [ windowTitle := primary
+               , windowModal := True
+               , containerBorderWidth := 6
+               , dialogHasSeparator := False
+               ]
+    image <- imageNewFromStock stockDialogError iconSizeDialog
+    set image [ miscYalign := 0.0 ]
+    label' <- labelNew $ Just $ "<span weight=\"bold\" size=\"larger\">"++
+                  escapeMarkup primary++"</span>\n\n"++escapeMarkup secondary
+    set label' [ labelUseMarkup := True
+               , labelWrap := True
+               , miscYalign := 0.0
+               ]
+    hBox <- hBoxNew False 0
+    set hBox [ boxSpacing := 12
+             , containerBorderWidth := 6
+             ]
+    boxPackStart hBox image PackNatural 0
+    boxPackStart hBox label' PackNatural 0
+
+    vBox <- dialogGetUpper dialog
+    set vBox [ boxSpacing := 12 ]
+    boxPackStart vBox hBox PackNatural 0
+
+    dialogAddButton dialog stockOk ResponseAccept
+    widgetShowAll hBox
+    return dialog
diff -rN -u old-fenfire-hs/Vobs.fhs new-fenfire-hs/Vobs.fhs
--- old-fenfire-hs/Vobs.fhs	2007-03-01 21:11:04.000000000 +0200
+++ new-fenfire-hs/Vobs.fhs	2007-03-01 21:11:05.000000000 +0200
@@ -327,10 +327,12 @@
     
 
 vobCanvas :: Ord b => IORef a -> View a b -> Handler Event a -> 
-                      Handler c a -> (a -> a -> IO ()) -> Color -> TimeDiff ->
+                      Handler c a -> (a -> a -> IO ()) -> 
+                      (Control.Exception.Exception -> IO ()) -> 
+                      Color -> TimeDiff ->
                       IO (DrawingArea, Bool -> IO (), c -> IO Bool)
 vobCanvas stateRef view eventHandler actionHandler stateChanged 
-          bgColor animTime = do
+          handleException bgColor animTime = do
     canvas <- drawingAreaNew
     
     widgetSetCanFocus canvas True
@@ -380,6 +382,8 @@
                     putStr ("Exception in event: ") >> print e
                     writeIORef stateRef state
                     stateChanged state state -- XXX how to write this?
+
+                    handleException e
                     return True )
 
         handleEvent = handle eventHandler
diff -rN -u old-fenfire-hs/VobTest.fhs new-fenfire-hs/VobTest.fhs
--- old-fenfire-hs/VobTest.fhs	2007-03-01 21:11:04.000000000 +0200
+++ new-fenfire-hs/VobTest.fhs	2007-03-01 21:11:05.000000000 +0200
@@ -164,6 +164,7 @@
     (canvas, _updateCanvas, _canvasAction) <- vobCanvas stateRef view handle 
                                                         (\_   -> return ()) 
                                                         (\_ _ -> return ()) 
+                                                        (\_   -> return ())
                                                         lightGray 3
 
     set window [ containerChild := canvas ]