Add basic support for GtkListStore and GtkTreeView

6 files changed, 211 insertions, 5 deletions

diff --git a/src/Gtk/Internal.dcl b/src/Gtk/Internal.dcl
index e7ac6d5..b606d1d 100644
--- a/src/Gtk/Internal.dcl
+++ b/src/Gtk/Internal.dcl
@@ -17,6 +17,8 @@ gtk_box_new :: !Bool !Int !.a -> (!Pointer, !.a)
 gtk_box_pack_start :: !Pointer !Pointer !Bool !Bool !Int !.a -> .a
 gtk_box_pack_end :: !Pointer !Pointer !Bool !Bool !Int !.a -> .a
 
+gtk_cell_renderer_text_new :: !.a -> (!Pointer, !.a)
+
 gtk_check_menu_item_get_active :: !Pointer !.a -> (!Bool, !.a)
 gtk_check_menu_item_new :: !.a -> (!Pointer, !.a)
 gtk_check_menu_item_set_active :: !Pointer !Bool !.a -> .a
@@ -46,6 +48,14 @@ gtk_frame_set_label_align :: !Pointer !Real !Real !.a -> .a
 
 gtk_init :: !.a -> .a
 
+gtk_list_store_append :: !Pointer -> .{#Int}
+gtk_list_store_newv :: !{#Int} !.a -> (!Pointer, !.a)
+gtk_list_store_set_bool :: !Pointer !.{#Int} !Int !Bool !.a -> .a
+gtk_list_store_set_char :: !Pointer !.{#Int} !Int !Char !.a -> .a
+gtk_list_store_set_int :: !Pointer !.{#Int} !Int !Int !.a -> .a
+gtk_list_store_set_real :: !Pointer !.{#Int} !Int !Real !.a -> .a
+gtk_list_store_set_string :: !Pointer !.{#Int} !Int !String !.a -> .a
+
 gtk_main_iteration :: !.a -> (!Bool, !.a)
 gtk_main_quit :: !.a -> .a
 
@@ -93,6 +103,14 @@ gtk_text_view_get_buffer :: !Pointer -> Pointer
 gtk_text_view_set_editable :: !Pointer !Bool !.a -> .a
 gtk_text_view_set_wrap_mode :: !Pointer !Int !.a -> .a
 
+gtk_tree_view_column_add_attribute :: !Pointer !Pointer !String !Int !.a -> .a
+gtk_tree_view_column_new :: !.a -> (!Pointer, !.a)
+gtk_tree_view_column_pack_start :: !Pointer !Pointer !Bool !.a -> .a
+gtk_tree_view_column_set_title :: !Pointer !String !.a -> .a
+
+gtk_tree_view_append_column :: !Pointer !Pointer !.a -> .a
+gtk_tree_view_new_with_model :: !Pointer !.a -> (!Pointer, !.a)
+
 gtk_widget_destroy :: !Pointer !.a -> .a
 gtk_widget_get_screen :: !Pointer !.a -> (!Pointer, !.a)
 gtk_widget_get_style_context :: !Pointer !.a -> (!Pointer, !.a)
diff --git a/src/Gtk/Internal.icl b/src/Gtk/Internal.icl
index a5e2256..36ef0c7 100644
--- a/src/Gtk/Internal.icl
+++ b/src/Gtk/Internal.icl
@@ -51,6 +51,11 @@ gtk_box_pack_end box child expand fill spacing env = code {
 	ccall gtk_box_pack_end "ppIII:V:A"
 }
 
+gtk_cell_renderer_text_new :: !.a -> (!Pointer, !.a)
+gtk_cell_renderer_text_new env = code {
+	ccall gtk_cell_renderer_text_new ":p:A"
+}
+
 gtk_check_menu_item_get_active :: !Pointer !.a -> (!Bool, !.a)
 gtk_check_menu_item_get_active item env = code {
 	ccall gtk_check_menu_item_get_active "p:I:A"
@@ -208,6 +213,72 @@ where
 		ccall gtk_init "pp:V:A"
 	}
 
+gtk_list_store_append :: !Pointer -> .{#Int}
+gtk_list_store_append store
+	# iter = createArray 4 0 // size of GtkTreeIter
+	# r = append store (get_array_pointer iter) 0
+	| r <> 0
+		= abort "internal error in gtk_list_store_append\n"
+		= iter
+where
+	append :: !Pointer !Pointer !a -> a
+	append _ _ _ = code {
+		ccall gtk_list_store_append "pp:V:A"
+	}
+
+gtk_list_store_newv :: !{#Int} !.a -> (!Pointer, !.a)
+gtk_list_store_newv types env = newv (size types) (get_array_pointer types) env
+where
+	newv :: !Int !Pointer !.a -> (!Pointer, !.a)
+	newv _ _ _ = code {
+		ccall gtk_list_store_newv "Ip:p:A"
+	}
+
+gtk_list_store_set_bool :: !Pointer !.{#Int} !Int !Bool !.a -> .a
+gtk_list_store_set_bool store iter col val env =
+	set store (get_array_pointer iter) col val -1 env
+where
+	set :: !Pointer !Pointer !Int !Bool !Int !.a -> .a
+	set _ _ _ _ _ _ = code {
+		ccall gtk_list_store_set "ppIII:V:A"
+	}
+
+gtk_list_store_set_char :: !Pointer !.{#Int} !Int !Char !.a -> .a
+gtk_list_store_set_char store iter col val env =
+	set store (get_array_pointer iter) col val -1 env
+where
+	set :: !Pointer !Pointer !Int !Char !Int !.a -> .a
+	set _ _ _ _ _ _ = code {
+		ccall gtk_list_store_set "ppIII:V:A"
+	}
+
+gtk_list_store_set_int :: !Pointer !.{#Int} !Int !Int !.a -> .a
+gtk_list_store_set_int store iter col val env =
+	set store (get_array_pointer iter) col val -1 env
+where
+	set :: !Pointer !Pointer !Int !Int !Int !.a -> .a
+	set _ _ _ _ _ _ = code {
+		ccall gtk_list_store_set "ppIII:V:A"
+	}
+
+gtk_list_store_set_real :: !Pointer !.{#Int} !Int !Real !.a -> .a
+gtk_list_store_set_real store iter col val env =
+	set store (get_array_pointer iter) col val -1 env
+where
+	set :: !Pointer !Pointer !Int !Real !Int !.a -> .a
+	set _ _ _ _ _ _ = code {
+		ccall gtk_list_store_set "ppIRI:V:A"
+	}
+
+gtk_list_store_set_string :: !Pointer !.{#Int} !Int !String !.a -> .a
+gtk_list_store_set_string store iter col val env =
+	set store (get_array_pointer iter) col (packString val) -1 env
+where
+	set :: !Pointer !Pointer !Int !String !Int !.a -> .a
+	set _ _ _ _ _ _ = code {
+		ccall gtk_list_store_set "ppIsI:V:A"
+	}
+
 gtk_main_iteration :: !.a -> (!Bool, !.a)
 gtk_main_iteration env = code {
 	ccall gtk_main_iteration "G:I:A"
@@ -409,6 +480,43 @@ gtk_text_view_set_wrap_mode text_view mode env = code {
 	ccall gtk_text_view_set_wrap_mode "pI:V:A"
 }
 
+gtk_tree_view_column_add_attribute :: !Pointer !Pointer !String !Int !.a -> .a
+gtk_tree_view_column_add_attribute tree_column renderer attr column env =
+	add tree_column renderer (packString attr) column env
+where
+	add :: !Pointer !Pointer !String !Int !.a -> .a
+	add _ _ _ _ _ = code {
+		ccall gtk_tree_view_column_add_attribute "ppsI:V:A"
+	}
+
+gtk_tree_view_column_new :: !.a -> (!Pointer, !.a)
+gtk_tree_view_column_new env = code {
+	ccall gtk_tree_view_column_new ":p:A"
+}
+
+gtk_tree_view_column_pack_start :: !Pointer !Pointer !Bool !.a -> .a
+gtk_tree_view_column_pack_start column renderer expand env = code {
+	ccall gtk_tree_view_column_pack_start "ppI:V:A"
+}
+
+gtk_tree_view_column_set_title :: !Pointer !String !.a -> .a
+gtk_tree_view_column_set_title column title env = set column (packString title) env
+where
+	set :: !Pointer !String !.a -> .a
+	set _ _ _ = code {
+		ccall gtk_tree_view_column_set_title "ps:V:A"
+	}
+
+gtk_tree_view_append_column :: !Pointer !Pointer !.a -> .a
+gtk_tree_view_append_column tree column env = code {
+	ccall gtk_tree_view_append_column "pp:V:A"
+}
+
+gtk_tree_view_new_with_model :: !Pointer !.a -> (!Pointer, !.a)
+gtk_tree_view_new_with_model model env = code {
+	ccall gtk_tree_view_new_with_model "p:p:A"
+}
+
 gtk_widget_destroy :: !Pointer !.a -> .a
 gtk_widget_destroy widget env = code {
 	ccall gtk_widget_destroy "p:V:A"
diff --git a/src/Gtk/Types.dcl b/src/Gtk/Types.dcl
index 33d0eb9..d53fcb7 100644
--- a/src/Gtk/Types.dcl
+++ b/src/Gtk/Types.dcl
@@ -2,6 +2,24 @@ definition module Gtk.Types
 
 from StdOverloaded import class fromInt, class toInt
 
+:: GType
+	// This is not exhaustive
+	= GTypeBool
+	| GTypeChar
+	| GTypeInt
+	| GTypeReal
+	| GTypeString
+
+instance toInt GType
+
+:: GValue
+	// This is not exhaustive
+	= GValueBool !Bool
+	| GValueChar !Char
+	| GValueInt !Int
+	| GValueReal !Real
+	| GValueString !String
+
 :: GtkButtonsType
 	= NoButtons
 	| OkButton
diff --git a/src/Gtk/Types.icl b/src/Gtk/Types.icl
index 22e6adc..8be86ff 100644
--- a/src/Gtk/Types.icl
+++ b/src/Gtk/Types.icl
@@ -3,6 +3,17 @@ implementation module Gtk.Types
 import StdEnv
 import StdDebug
 
+instance toInt GType
+where
+	toInt type = id << 2
+	where
+		id = case type of
+			GTypeBool   ->  5
+			GTypeChar   ->  3
+			GTypeInt    ->  6
+			GTypeReal   -> 15
+			GTypeString -> 16
+
 instance toInt GtkButtonsType
 where
 	toInt type = case type of
diff --git a/src/Gtk/Widgets.dcl b/src/Gtk/Widgets.dcl
index 5f2baa5..a80d9a6 100644
--- a/src/Gtk/Widgets.dcl
+++ b/src/Gtk/Widgets.dcl
@@ -7,11 +7,13 @@ from System._Pointer import :: Pointer
 
 from Gtk.State import :: GtkM
 from Gtk.Tune import class tune
-from Gtk.Types import :: GtkButtonsType, :: GtkCSSClass, :: GtkDirection,
-	:: GtkExpand, :: GtkFileChooserAction, :: GtkLabel, :: GtkMargins,
-	:: GtkMessageType, :: GtkModal, :: GtkOrientation, :: GtkPanedHandleWidth,
-	:: GtkResize, :: GtkResponse, :: GtkScrollbarPolicy, :: GtkShrink,
-	:: GtkStylePriority, :: GtkTitle, :: GtkWrapMode
+from Gtk.Types import
+	:: GType, :: GValue,
+	:: GtkButtonsType, :: GtkCSSClass, :: GtkDirection, :: GtkExpand,
+	:: GtkFileChooserAction, :: GtkLabel, :: GtkMargins, :: GtkMessageType,
+	:: GtkModal, :: GtkOrientation, :: GtkPanedHandleWidth, :: GtkResize,
+	:: GtkResponse, :: GtkScrollbarPolicy, :: GtkShrink, :: GtkStylePriority,
+	:: GtkTitle, :: GtkWrapMode
 
 class ptr a
 where
@@ -63,6 +65,11 @@ instance ptr GtkFrame
 newFrame :: !GtkLabel !w -> GtkM GtkFrame | gtkWidget w
 framed :: !GtkLabel !(GtkM w) -> GtkM (w, GtkFrame) | gtkWidget w
 
+:: GtkListStore
+
+newListStore :: ![GType] -> GtkM GtkListStore
+appendToListStore :: ![GValue] !GtkListStore -> GtkM GtkListStore
+
 :: GtkMenu
 instance gtkWidget GtkMenu
 
@@ -147,6 +154,12 @@ getTextBuffer :: !GtkTextView -> GtkTextBuffer
 
 instance tune GtkTextView GtkWrapMode
 
+:: GtkTreeView
+instance gtkWidget GtkTreeView
+
+newTreeView :: !GtkListStore -> GtkM GtkTreeView
+appendColumnToTreeView :: !String !Int !GtkExpand !GtkTreeView -> GtkM GtkTreeView
+
 :: GtkWidget
 
 class gtkWidget a :: !a -> GtkWidget
diff --git a/src/Gtk/Widgets.icl b/src/Gtk/Widgets.icl
index f2c942f..0848122 100644
--- a/src/Gtk/Widgets.icl
+++ b/src/Gtk/Widgets.icl
@@ -127,6 +127,27 @@ framed label widgetf =
 	widgetf >>= \widget ->
 	tuple widget <$> newFrame label widget
 
+:: GtkListStore :== Pointer
+
+newListStore :: ![GType] -> GtkM GtkListStore
+newListStore types = toStateR (gtk_list_store_newv {toInt t \\ t <- types})
+
+appendToListStore :: ![GValue] !GtkListStore -> GtkM GtkListStore
+appendToListStore values store =
+	set 0 values (gtk_list_store_append store) >>|
+	pure store
+where
+	set :: !Int ![GValue] !.{#Int} -> GtkM ()
+	set col [v:vs] iter = set` >>| set (col+1) vs iter
+	where
+		set` = case v of
+			GValueBool b   -> toState (gtk_list_store_set_bool   store iter col b)
+			GValueChar c   -> toState (gtk_list_store_set_char   store iter col c)
+			GValueInt i    -> toState (gtk_list_store_set_int    store iter col i)
+			GValueReal r   -> toState (gtk_list_store_set_real   store iter col r)
+			GValueString s -> toState (gtk_list_store_set_string store iter col s)
+	set _ [] _ = pure ()
+
 :: GtkMenu :== Pointer
 
 instance gtkWidget GtkMenu where gtkWidget m = m
@@ -308,6 +329,23 @@ where
 		toState (gtk_text_view_set_wrap_mode text_view (toInt mode)) >>|
 		pure text_view
 
+:: GtkTreeView :== Pointer
+
+instance gtkWidget GtkTreeView where gtkWidget tv = tv
+
+newTreeView :: !GtkListStore -> GtkM GtkTreeView
+newTreeView store = toStateR (gtk_tree_view_new_with_model store) >>= show
+
+appendColumnToTreeView :: !String !Int !GtkExpand !GtkTreeView -> GtkM GtkTreeView
+appendColumnToTreeView title col expand tree_view =
+	toStateR gtk_cell_renderer_text_new >>= \renderer ->
+	toStateR gtk_tree_view_column_new >>= \column ->
+	toState (gtk_tree_view_column_set_title column title) >>|
+	toState (gtk_tree_view_column_pack_start column renderer expand=:Expand) >>|
+	toState (gtk_tree_view_column_add_attribute column renderer "text" col) >>|
+	toState (gtk_tree_view_append_column tree_view column) >>|
+	pure tree_view
+
 :: GtkWidget :== Pointer
 
 instance gtkWidget GtkWidget where gtkWidget w = w