[Fencommits] fenfire-hs: move more from Fenfire to GtkFixes

[Tuukka Hastrup]

Fri Feb 16 01:43:09 EET 2007  Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
  * move more from Fenfire to GtkFixes
diff -rN -u old-fenfire-hs/Fenfire.fhs new-fenfire-hs/Fenfire.fhs
--- old-fenfire-hs/Fenfire.fhs	2007-02-16 01:45:44.000000000 +0200
+++ new-fenfire-hs/Fenfire.fhs	2007-02-16 01:45:45.000000000 +0200
@@ -50,6 +50,7 @@
 import GtkFixes
 import Graphics.UI.Gtk hiding (Color, get, disconnect, fill,
 -- GtkFixes overrides:
+                               actionNew,
                                widgetGetStyle,
                                styleGetForeground, styleGetBackground, 
                                styleGetLight, styleGetMiddle, styleGetDark,
@@ -542,8 +543,7 @@
             , ( "about"  , stockAbout         )
             ]
     flip mapM actionentries $ \(name,stock) -> do 
-        item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label
-        action <- actionNew name (siLabel $ fromJust item) Nothing (Just stock)
+        action <- actionNew name Nothing Nothing (Just stock)
         actionGroupAddActionWithAccel actionGroup action Nothing
         actionSetAccelGroup action accelGroup
 
@@ -575,14 +575,12 @@
                stockGoForward     , Just "<Ctl>L"         )
             ]
     flip mapM bindingentries $ \(name,label',stock,accel) -> do 
-        item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label
-        let label'' = maybe (siLabel $ fromJust item) id label'
-        action <- actionNew name label'' Nothing (Just stock)
+        action <- actionNew name label' Nothing (Just stock)
         actionGroupAddActionWithAccel actionGroup action accel
         actionSetAccelGroup action bindings
 
     flip mapM ?views $ \(name, _view) -> do
-        action <- actionNew name name Nothing Nothing
+        action <- actionNew name (Just name) Nothing Nothing
         actionGroupAddAction actionGroup action
 
 makeMenus actionGroup root = mapM_ (createMenu root) menuentries
@@ -740,13 +738,13 @@
 
     -- action widgets:
 
-    accelGroup <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs
+    accelGroup <- accelGroupNew
     windowAddAccelGroup window accelGroup
     -- bindings are active only when the canvas has the focus:
-    bindings <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs
+    bindings <- accelGroupNew
     windowAddAccelGroup window bindings
     -- fake bindings aren't used
-    fake <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs
+    fake <- accelGroupNew
 
     actionGroup <- actionGroupNew "main"
     bindingGroup <- actionGroupNew "bindings"
diff -rN -u old-fenfire-hs/GtkFixes.hs new-fenfire-hs/GtkFixes.hs
--- old-fenfire-hs/GtkFixes.hs	2007-02-16 01:45:44.000000000 +0200
+++ new-fenfire-hs/GtkFixes.hs	2007-02-16 01:45:45.000000000 +0200
@@ -36,8 +36,24 @@
 import System.Glib.GObject
 import System.Glib.FFI
 import Graphics.UI.Gtk
+import qualified Graphics.UI.Gtk
 import Graphics.UI.Gtk.Types
 
+
+-- while Gtk2Hs actionNew needs the label:
+actionNew name maybeLabel tooltip stock = do
+    item <- maybe (return Nothing) stockLookupItem stock
+    let label' = case (maybeLabel, fmap siLabel item) of
+            (Just label, _) -> label
+            (_, Just label) -> label
+            _               -> error "actionNew: no label"
+    Graphics.UI.Gtk.actionNew name label' tooltip stock
+
+-- until Gtk2Hs gets another way to create accel groups:
+accelGroupNew :: IO AccelGroup
+accelGroupNew = uiManagerNew >>= uiManagerGetAccelGroup
+
+
 -- from Widget.hs generated from Benja's style patch to gtk2hs:
 widgetGetStyle :: WidgetClass widget => widget -> IO Style
 widgetGetStyle widget = do