Add basic functionality for accelerators (i.e. shortcuts)

6 files changed, 103 insertions, 0 deletions

diff --git a/src/Gtk/Internal.dcl b/src/Gtk/Internal.dcl
index 3528628..25cb7fe 100644
--- a/src/Gtk/Internal.dcl
+++ b/src/Gtk/Internal.dcl
@@ -13,6 +13,10 @@ g_signal_connect :: !Int !Pointer !String !Int !.a -> .a
 g_timeout_add :: !Int !Int !.a -> .a
 g_timeout_add_seconds :: !Int !Int !.a -> .a
 
+gdk_keyval_from_name :: !String -> Int
+
+gtk_accel_group_new :: !.a -> (!Pointer, !.a)
+
 gtk_action_bar_new :: !.a -> (!Pointer, !.a)
 gtk_action_bar_pack_start :: !Pointer !Pointer !.a -> .a
 gtk_action_bar_pack_end :: !Pointer !Pointer !.a -> .a
@@ -143,6 +147,7 @@ gtk_tree_view_get_model :: !Pointer -> Pointer
 gtk_tree_view_get_selection :: !Pointer -> Pointer
 gtk_tree_view_new_with_model :: !Pointer !.a -> (!Pointer, !.a)
 
+gtk_widget_add_accelerator :: !Pointer !String !Pointer !Int !Int !Int !.a -> .a
 gtk_widget_destroy :: !Pointer !.a -> .a
 gtk_widget_get_screen :: !Pointer !.a -> (!Pointer, !.a)
 gtk_widget_get_style_context :: !Pointer !.a -> (!Pointer, !.a)
@@ -159,6 +164,7 @@ gtk_widget_set_valign :: !Pointer !Int !.a -> .a
 gtk_widget_set_vexpand :: !Pointer !Bool !.a -> .a
 gtk_widget_show :: !Pointer !.a -> .a
 
+gtk_window_add_accel_group :: !Pointer !Pointer !.a -> .a
 gtk_window_new :: !Bool !.a -> (!Pointer, !.a)
 gtk_window_set_title :: !Pointer !String !.a -> .a
 gtk_window_set_transient_for :: !Pointer !Pointer !.a -> .a
diff --git a/src/Gtk/Internal.icl b/src/Gtk/Internal.icl
index dc2e17a..baa3be7 100644
--- a/src/Gtk/Internal.icl
+++ b/src/Gtk/Internal.icl
@@ -36,6 +36,19 @@ g_timeout_add_seconds interval id env = code {
 	ccall clean_g_timeout_add_seconds "II:V:A"
 }
 
+gdk_keyval_from_name :: !String -> Int
+gdk_keyval_from_name name = get (packString name)
+where
+	get :: !String -> Int
+	get _ = code {
+		ccall gdk_keyval_from_name "s:I"
+	}
+
+gtk_accel_group_new :: !.a -> (!Pointer, !.a)
+gtk_accel_group_new env = code {
+	ccall gtk_accel_group_new ":p:A"
+}
+
 gtk_action_bar_new :: !.a -> (!Pointer, !.a)
 gtk_action_bar_new env = code {
 	ccall gtk_action_bar_new ":p:A"
@@ -676,6 +689,15 @@ gtk_tree_view_new_with_model model env = code {
 	ccall gtk_tree_view_new_with_model "p:p:A"
 }
 
+gtk_widget_add_accelerator :: !Pointer !String !Pointer !Int !Int !Int !.a -> .a
+gtk_widget_add_accelerator widget signal accel_group key mask flags env =
+	add widget (packString signal) accel_group key mask flags env
+where
+	add :: !Pointer !String !Pointer !Int !Int !Int !.a -> .a
+	add _ _ _ _ _ _ _ = code {
+		ccall gtk_widget_add_accelerator "pspIII:V:A"
+	}
+
 gtk_widget_destroy :: !Pointer !.a -> .a
 gtk_widget_destroy widget env = code {
 	ccall gtk_widget_destroy "p:V:A"
@@ -751,6 +773,11 @@ gtk_widget_show widget env = code {
 	ccall gtk_widget_show "p:V:A"
 }
 
+gtk_window_add_accel_group :: !Pointer !Pointer !.a -> .a
+gtk_window_add_accel_group window group env = code {
+	ccall gtk_window_add_accel_group "pp:V:A"
+}
+
 gtk_window_new :: !Bool !.a -> (!Pointer, !.a)
 gtk_window_new is_popup env = code {
 	ccall gtk_window_new "I:p:A"
diff --git a/src/Gtk/Types.dcl b/src/Gtk/Types.dcl
index 6f141a4..eaaa5a8 100644
--- a/src/Gtk/Types.dcl
+++ b/src/Gtk/Types.dcl
@@ -20,6 +20,27 @@ instance toInt GType
 	| GValueReal !Real
 	| GValueString !String
 
+:: GdkModifier
+	= ShiftMask
+	| LockMask
+	| ControlMask
+	| Mod1Mask
+	| Mod2Mask
+	| Mod3Mask
+	| Mod4Mask
+	| Mod5Mask
+	| Button1Mask
+	| Button2Mask
+	| Button3Mask
+	| Button4Mask
+	| Button5Mask
+	| SuperMask
+	| HyperMask
+	| MetaMask
+
+instance toInt GdkModifier
+instance toInt [GdkModifier]
+
 :: GtkAlign
 	= AlignFill
 	| AlignStart
diff --git a/src/Gtk/Types.icl b/src/Gtk/Types.icl
index e7cc233..ad9acca 100644
--- a/src/Gtk/Types.icl
+++ b/src/Gtk/Types.icl
@@ -14,6 +14,33 @@ where
 			GTypeReal   -> 15
 			GTypeString -> 16
 
+instance toInt GdkModifier
+where
+	toInt modifier = 1 << shift
+	where
+		shift = case modifier of
+			ShiftMask   ->  0
+			LockMask    ->  1
+			ControlMask ->  2
+			Mod1Mask    ->  3
+			Mod2Mask    ->  4
+			Mod3Mask    ->  5
+			Mod4Mask    ->  6
+			Mod5Mask    ->  7
+			Button1Mask ->  8
+			Button2Mask ->  9
+			Button3Mask -> 10
+			Button4Mask -> 11
+			Button5Mask -> 12
+			SuperMask   -> 26
+			HyperMask   -> 27
+			MetaMask    -> 28
+
+instance toInt [GdkModifier]
+where
+	toInt [m:ms] = toInt m bitor toInt ms
+	toInt []     = 0
+
 instance toInt GtkAlign
 where
 	toInt align = case align of
diff --git a/src/Gtk/Widgets.dcl b/src/Gtk/Widgets.dcl
index 7497b3e..4d684ef 100644
--- a/src/Gtk/Widgets.dcl
+++ b/src/Gtk/Widgets.dcl
@@ -9,12 +9,19 @@ from Gtk.State import :: GtkM
 from Gtk.Tune import class tune
 from Gtk.Types import
 	:: GType, :: GValue,
+	:: GdkModifier,
 	:: GtkAlign, :: GtkButtonsType, :: GtkCSSClass, :: GtkDirection,
 	:: GtkExpand, :: GtkFileChooserAction, :: GtkMargins, :: GtkMessageType,
 	:: GtkModal, :: GtkOrientation, :: GtkPanedHandleWidth, :: GtkResize,
 	:: GtkResponse, :: GtkScrollbarPolicy, :: GtkSensitivity, :: GtkShrink,
 	:: GtkSpacing, :: GtkStylePriority, :: GtkText, :: GtkTitle, :: GtkWrapMode
 
+:: GtkAccelGroup =: GtkAccelGroup Pointer
+
+newAccelGroup :: !w -> GtkM GtkAccelGroup | gtkWindow w
+
+:: GtkAccelerator = Accelerator !GtkAccelGroup !String ![GdkModifier]
+
 :: GtkActionBar =: GtkActionBar Pointer
 instance gtkWidget GtkActionBar
 
@@ -218,6 +225,7 @@ setMargins :: !GtkMargins !w -> GtkM w | gtkWidget w
 instance tune w GtkSensitivity | gtkWidget w
 instance tune w (GtkAlign,GtkAlign) | gtkWidget w
 instance tune w (GtkExpand,GtkExpand) | gtkWidget w
+instance tune w GtkAccelerator | gtkWidget w
 
 :: GtkWindow =: GtkWindow Pointer
 
diff --git a/src/Gtk/Widgets.icl b/src/Gtk/Widgets.icl
index 5290d9f..9500b5f 100644
--- a/src/Gtk/Widgets.icl
+++ b/src/Gtk/Widgets.icl
@@ -14,6 +14,13 @@ import qualified Text
 import Gtk
 import Gtk.Internal
 
+newAccelGroup :: !w -> GtkM GtkAccelGroup | gtkWindow w
+newAccelGroup window =
+	let (GtkWindow w) = gtkWindow window in
+	toStateR gtk_accel_group_new >>= \ag ->
+	toState (gtk_window_add_accel_group w ag) >>|
+	pure (GtkAccelGroup ag)
+
 instance gtkWidget GtkActionBar where gtkWidget (GtkActionBar ab) = GtkWidget ab
 
 newActionBar :: GtkM GtkActionBar
@@ -520,6 +527,13 @@ where
 		toState (gtk_widget_set_vexpand w vexpand=:Expand) >>|
 		pure widget
 
+instance tune w GtkAccelerator | gtkWidget w
+where
+	tune (Accelerator (GtkAccelGroup ag) key mask) widget =
+		let (GtkWidget w) = gtkWidget widget in
+		toState (gtk_widget_add_accelerator w "activate" ag (gdk_keyval_from_name key) (toInt mask) 1) >>|
+		pure widget
+
 instance gtkWidget GtkWindow where gtkWidget (GtkWindow w) = GtkWidget w
 instance gtkContainer GtkWindow where gtkContainer (GtkWindow w) = GtkContainer w
 instance gtkWindow GtkWindow where gtkWindow w = w