Add CSS support

8 files changed, 130 insertions, 4 deletions

diff --git a/src/Gtk/Internal.dcl b/src/Gtk/Internal.dcl
index c07b71a..d3821f7 100644
--- a/src/Gtk/Internal.dcl
+++ b/src/Gtk/Internal.dcl
@@ -19,6 +19,9 @@ gtk_box_pack_end :: !Pointer !Pointer !Bool !Bool !Int !.a -> .a
 
 gtk_container_add :: !Pointer !Pointer !.a -> .a
 
+gtk_css_provider_new :: !.a -> (!Pointer, !.a)
+gtk_css_provider_load_from_path :: !Pointer !String !Pointer !.a -> (!Bool, !.a)
+
 gtk_frame_new :: !(Maybe String) !.a -> (!Pointer, !.a)
 gtk_frame_set_label_align :: !Pointer !Real !Real !.a -> .a
 
@@ -32,12 +35,19 @@ gtk_paned_pack1 :: !Pointer !Pointer !Bool !Bool !.a -> .a
 gtk_paned_pack2 :: !Pointer !Pointer !Bool !Bool !.a -> .a
 gtk_paned_set_wide_handle :: !Pointer !Bool !.a -> .a
 
+gtk_style_context_add_class :: !Pointer !String !.a -> .a
+gtk_style_context_add_provider :: !Pointer !Pointer !Int !.a -> .a
+gtk_style_context_add_provider_for_screen :: !Pointer !Pointer !Int !.a -> .a
+gtk_style_context_remove_class :: !Pointer !String !.a -> .a
+
 gtk_text_buffer_insert_at_cursor :: !Pointer !String !Int !.a -> .a
 
 gtk_text_view_new :: !.a -> (!Pointer, !.a)
 gtk_text_view_get_buffer :: !Pointer -> Pointer
 gtk_text_view_set_editable :: !Pointer !Bool !.a -> .a
 
+gtk_widget_get_screen :: !Pointer !.a -> (!Pointer, !.a)
+gtk_widget_get_style_context :: !Pointer !.a -> (!Pointer, !.a)
 gtk_widget_set_margin_bottom :: !Pointer !Int !.a -> .a
 gtk_widget_set_margin_left :: !Pointer !Int !.a -> .a
 gtk_widget_set_margin_right :: !Pointer !Int !.a -> .a
diff --git a/src/Gtk/Internal.icl b/src/Gtk/Internal.icl
index 24e22cb..ffa801e 100644
--- a/src/Gtk/Internal.icl
+++ b/src/Gtk/Internal.icl
@@ -55,6 +55,21 @@ gtk_container_add container widget env = code {
 	ccall gtk_container_add "pp:V:A"
 }
 
+gtk_css_provider_new :: !.a -> (!Pointer, !.a)
+gtk_css_provider_new env = code {
+	ccall gtk_css_provider_new ":p:A"
+}
+
+// TODO: this relies on a deprecated return value; we should connect to the
+// parsing-error signal instead.
+gtk_css_provider_load_from_path :: !Pointer !String !Pointer !.a -> (!Bool, !.a)
+gtk_css_provider_load_from_path provider path error env = load provider (packString path) error env
+where
+	load :: !Pointer !String !Pointer !.a -> (!Bool, !.a)
+	load _ _ _ _ = code {
+		ccall gtk_css_provider_load_from_path "psp:I:A"
+	}
+
 gtk_frame_new :: !(Maybe String) !.a -> (!Pointer, !.a)
 gtk_frame_new Nothing env = new 0 env
 where
@@ -123,6 +138,32 @@ gtk_paned_set_wide_handle paned setting env = code {
 	ccall gtk_paned_set_wide_handle "pI:V:A"
 }
 
+gtk_style_context_add_class :: !Pointer !String !.a -> .a
+gtk_style_context_add_class context cls env = add context (packString cls) env
+where
+	add :: !Pointer !String !.a -> .a
+	add _ _ _ = code {
+		ccall gtk_style_context_add_class "ps:V:A"
+	}
+
+gtk_style_context_add_provider :: !Pointer !Pointer !Int !.a -> .a
+gtk_style_context_add_provider context provider priority env = code {
+	ccall gtk_style_context_add_provider "ppI:V:A"
+}
+
+gtk_style_context_add_provider_for_screen :: !Pointer !Pointer !Int !.a -> .a
+gtk_style_context_add_provider_for_screen context provider priority env = code {
+	ccall gtk_style_context_add_provider_for_screen "ppI:V:A"
+}
+
+gtk_style_context_remove_class :: !Pointer !String !.a -> .a
+gtk_style_context_remove_class context cls env = remove context (packString cls) env
+where
+	remove :: !Pointer !String !.a -> .a
+	remove _ _ _ = code {
+		ccall gtk_style_context_remove_class "ps:V:A"
+	}
+
 gtk_text_buffer_insert_at_cursor :: !Pointer !String !Int !.a -> .a
 gtk_text_buffer_insert_at_cursor buffer string len env = code {
 	ccall gtk_text_buffer_insert_at_cursor "psI:V:A"
@@ -143,6 +184,16 @@ gtk_text_view_set_editable text_view setting env = code {
 	ccall gtk_text_view_set_editable "pI:V:A"
 }
 
+gtk_widget_get_screen :: !Pointer !.a -> (!Pointer, !.a)
+gtk_widget_get_screen widget env = code {
+	ccall gtk_widget_get_screen "p:p:A"
+}
+
+gtk_widget_get_style_context :: !Pointer !.a -> (!Pointer, !.a)
+gtk_widget_get_style_context widget env = code {
+	ccall gtk_widget_get_style_context "p:p:A"
+}
+
 gtk_widget_set_margin_bottom :: !Pointer !Int !.a -> .a
 gtk_widget_set_margin_bottom widget padding env = code {
 	ccall gtk_widget_set_margin_bottom "pI:V:A"
diff --git a/src/Gtk/Tune.dcl b/src/Gtk/Tune.dcl
index 07d0507..63ad69d 100644
--- a/src/Gtk/Tune.dcl
+++ b/src/Gtk/Tune.dcl
@@ -1,7 +1,7 @@
 definition module Gtk.Tune
 
 from Gtk.State import :: StateT, :: Identity, :: State, :: GtkState, :: GtkM
-from Gtk.Types import :: GtkMargins
+from Gtk.Types import :: GtkCSSClass, :: GtkMargins
 from Gtk.Widgets import :: GtkWidget, class gtkWidget
 
 class tune elem option :: !(GtkM elem) !option -> GtkM elem
@@ -10,3 +10,4 @@ class tune elem option :: !(GtkM elem) !option -> GtkM elem
 (<<@) elem option :== tune elem option
 
 instance tune w GtkMargins | gtkWidget w
+instance tune w GtkCSSClass | gtkWidget w
diff --git a/src/Gtk/Tune.icl b/src/Gtk/Tune.icl
index 26a05f3..c5846af 100644
--- a/src/Gtk/Tune.icl
+++ b/src/Gtk/Tune.icl
@@ -13,3 +13,10 @@ where
 		widgetf >>= \widget ->
 		setMargins margins widget >>|
 		pure widget
+
+instance tune w GtkCSSClass | gtkWidget w
+where
+	tune widgetf cls =
+		widgetf >>= \widget ->
+		addCSSClass cls widget >>|
+		pure widget
diff --git a/src/Gtk/Types.dcl b/src/Gtk/Types.dcl
index b51f80e..fda694b 100644
--- a/src/Gtk/Types.dcl
+++ b/src/Gtk/Types.dcl
@@ -1,5 +1,10 @@
 definition module Gtk.Types
 
+from StdOverloaded import class toInt
+
+:: GtkCSSClass
+	= Class !String
+
 :: GtkDirection
 	= StartToEnd
 	| EndToStart
@@ -36,3 +41,12 @@ margin :: !Int -> GtkMargins
 :: GtkShrink
 	= Shrink
 	| NoShrink
+
+:: GtkStylePriority
+	= StylePriorityFallback
+	| StylePriorityTheme
+	| StylePrioritySettings
+	| StylePriorityApplication
+	| StylePriorityUser
+
+instance toInt GtkStylePriority
diff --git a/src/Gtk/Types.icl b/src/Gtk/Types.icl
index aa03391..f8fa6cc 100644
--- a/src/Gtk/Types.icl
+++ b/src/Gtk/Types.icl
@@ -1,5 +1,7 @@
 implementation module Gtk.Types
 
+import StdEnv
+
 margin :: !Int -> GtkMargins
 margin n =
 	{ left   = n
@@ -7,3 +9,12 @@ margin n =
 	, right  = n
 	, bottom = n
 	}
+
+instance toInt GtkStylePriority
+where
+	toInt prio = case prio of
+		StylePriorityFallback     ->   1
+		StylePriorityTheme        -> 200
+		StylePrioritySettings     -> 400
+		StylePriorityApplication  -> 600
+		StylePriorityUser         -> 800
diff --git a/src/Gtk/Widgets.dcl b/src/Gtk/Widgets.dcl
index ee290c4..d7df700 100644
--- a/src/Gtk/Widgets.dcl
+++ b/src/Gtk/Widgets.dcl
@@ -2,12 +2,13 @@ definition module Gtk.Widgets
 
 from StdMaybe import :: Maybe
 
+from System.FilePath import :: FilePath
 from System._Pointer import :: Pointer
 
 from Gtk.State import :: State, :: StateT, :: Identity, :: GtkState, :: GtkM
-from Gtk.Types import :: GtkDirection, :: GtkExpand, :: GtkLabel,
-	:: GtkMargins, :: GtkOrientation, :: GtkPanedHandleWidth, :: GtkResize,
-	:: GtkShrink
+from Gtk.Types import :: GtkCSSClass, :: GtkDirection, :: GtkExpand,
+	:: GtkLabel, :: GtkMargins, :: GtkOrientation, :: GtkPanedHandleWidth,
+	:: GtkResize, :: GtkShrink, :: GtkStylePriority
 
 class ptr a :: !a -> Pointer
 
@@ -18,6 +19,8 @@ class gtkWidget a :: !a -> GtkWidget
 instance gtkWidget GtkWidget
 instance ptr GtkWidget
 
+addCSSClass :: !GtkCSSClass !w -> GtkM () | gtkWidget w
+removeCSSClass :: !GtkCSSClass !w -> GtkM () | gtkWidget w
 setMargins :: !GtkMargins !w -> GtkM () | gtkWidget w
 
 :: GtkContainer
@@ -68,3 +71,4 @@ instance gtkContainer GtkWindow
 
 newPopup :: !String !(Maybe (Int,Int)) -> GtkM GtkWindow
 newWindow :: !String !(Maybe (Int,Int)) -> GtkM GtkWindow
+addCSSFromFile :: !GtkStylePriority !FilePath !GtkWindow -> GtkM Bool
diff --git a/src/Gtk/Widgets.icl b/src/Gtk/Widgets.icl
index ba0ed6d..7fda320 100644
--- a/src/Gtk/Widgets.icl
+++ b/src/Gtk/Widgets.icl
@@ -8,6 +8,7 @@ import Control.Monad.Identity
 import Control.Monad.State
 import Data.Functor
 import Data.Tuple
+import System.FilePath
 import System._Pointer
 
 import qualified Gtk.Internal as I
@@ -19,6 +20,16 @@ import Gtk.Types
 instance gtkWidget GtkWidget where gtkWidget w = w
 instance ptr GtkWidget where ptr w = w
 
+addCSSClass :: !GtkCSSClass !w -> GtkM () | gtkWidget w
+addCSSClass (Class cls) widget =
+	toStateR ('I'.gtk_widget_get_style_context (gtkWidget widget)) >>= \context ->
+	toState ('I'.gtk_style_context_add_class context cls)
+
+removeCSSClass :: !GtkCSSClass !w -> GtkM () | gtkWidget w
+removeCSSClass (Class cls) widget =
+	toStateR ('I'.gtk_widget_get_style_context (gtkWidget widget)) >>= \context ->
+	toState ('I'.gtk_style_context_remove_class context cls)
+
 setMargins :: !GtkMargins !w -> GtkM () | gtkWidget w
 setMargins {left,top,right,bottom} widget` =
 	let widget = gtkWidget widget` in
@@ -130,3 +141,20 @@ new_window_or_popup is_popup title size =
 		Nothing    -> pure ()
 		Just (h,v) -> toState ('I'.gtk_widget_set_size_request window h v)) >>|
 	show window
+
+// NB: it is also possible to attach CSS to one widget in particular (excluding
+// children widgets). You then use gtk_widget_get_style_context and gtk_style_
+// context_add_provider instead of gtk_widget_get_screen and gtk_style_context_
+// add_provider_for_screen. This functionality has not been added to this
+// library yet, but there is no reason to not provide it. To be clear that this
+// style is global, we only allow it on GtkWindow, even though it would work on
+// any GtkWidget.
+addCSSFromFile :: !GtkStylePriority !FilePath !GtkWindow -> GtkM Bool
+addCSSFromFile priority path window =
+	toStateR 'I'.gtk_css_provider_new >>= \provider ->
+	toStateR ('I'.gtk_css_provider_load_from_path provider path 0) >>= \ok
+		| not ok -> pure ok
+		| otherwise ->
+			toStateR ('I'.gtk_widget_get_screen window) >>= \screen ->
+			toState ('I'.gtk_style_context_add_provider_for_screen screen provider (toInt priority)) >>|
+			pure True