path: root/src/Gtk/Widgets.icl

implementation module Gtk.Widgets

import StdEnv
import StdMaybe

import Control.Monad
import Data.Functor
import Data.Tuple
import System.FilePath
import System._Pointer
from Text import class Text(split), instance Text String
import qualified Text

import Gtk
import Gtk.Internal

:: GtkActionBar :== Pointer

instance gtkWidget GtkActionBar where gtkWidget ab = ab

newActionBar :: GtkM GtkActionBar
newActionBar = toStateR gtk_action_bar_new >>= show

packActionBar :: !GtkActionBar !GtkDirection !w -> GtkM w | gtkWidget w
packActionBar bar dir widget =
	toState
		(if dir=:StartToEnd gtk_action_bar_pack_start gtk_action_bar_pack_end
			bar
			(gtkWidget widget)) >>|
	pure widget

:: GtkBox :== Pointer

instance gtkWidget GtkBox where gtkWidget b = b
instance gtkContainer GtkBox where gtkContainer b = b
instance gtkOrientable GtkBox where gtkOrientable b = b

newBox :: !GtkOrientation !Int -> GtkM GtkBox
newBox orientation spacing =
	toStateR (gtk_box_new orientation=:Vertical spacing) >>=
	show

packBox :: !GtkBox !GtkDirection !GtkExpand !w -> GtkM w | gtkWidget w
packBox box direction expand widget =
	toState (if direction=:StartToEnd gtk_box_pack_start gtk_box_pack_end
		box (gtkWidget widget) expand=:Expand True 0) >>|
	pure widget

instance tune GtkBox GtkSpacing
where
	tune (Spacing s) box = toState (gtk_box_set_spacing box s) >>| pure box

:: GtkButton :== Pointer

instance gtkWidget GtkButton where gtkWidget b = b
instance ptr GtkButton
where
	toPtr   b = b
	fromPtr b = b

newButtonFromIconName :: !String -> GtkM GtkButton
newButtonFromIconName icon =
	toStateR (gtk_button_new_from_icon_name icon (toInt ButtonIconSize)) >>=
	show

:: GtkContainer :== Pointer

instance gtkWidget GtkContainer where gtkWidget c = c
instance gtkContainer GtkContainer where gtkContainer c = c

instance ptr GtkContainer
where
	toPtr   c = c
	fromPtr c = c

addToContainer :: !c !w -> GtkM w | gtkWidget w & gtkContainer c
addToContainer container widget =
	toState (gtk_container_add (gtkContainer container) (gtkWidget widget)) >>|
	pure widget

:: GtkDialog :== Pointer

instance gtkWidget GtkDialog where gtkWidget d = d
instance gtkContainer GtkDialog where gtkContainer d = d
instance gtkWindow GtkDialog where gtkWindow w = w
instance gtkDialog GtkDialog where gtkDialog d = d

instance ptr GtkDialog
where
	toPtr   d = d
	fromPtr d = d

instance tune d GtkModal | gtkDialog d
where
	tune setting dialog =
		toState (gtk_dialog_set_modal (gtkDialog dialog) setting=:Modal) >>|
		pure dialog

newDialog :: !GtkWindow -> GtkM GtkDialog
newDialog window =
	toStateR gtk_dialog_new >>= \dialog ->
	toState (gtk_window_set_transient_for dialog window) >>|
	pure dialog

runDialog :: !d -> GtkM GtkResponse | gtkDialog d
runDialog dialog = fromInt <$> toStateR (gtk_dialog_run (gtkDialog dialog))

getContentArea :: !d -> GtkBox | gtkDialog d
getContentArea dialog = gtk_dialog_get_content_area (gtkDialog dialog)

newMessageDialog :: !GtkWindow !GtkMessageType !GtkButtonsType !String -> GtkM GtkDialog
newMessageDialog window type buttons text =
	toStateR (gtk_message_dialog_new_with_markup
		window
		1 /* DESTROY_WITH_PARENT */
		(toInt type)
		(toInt buttons)
		text)

getFileWithDialog :: !GtkWindow !GtkFileChooserAction !(Maybe String) -> GtkM (Maybe FilePath)
getFileWithDialog window action title =
	toStateR (gtk_file_chooser_dialog_new title window (toInt action) buttons) >>= \dialog ->
	toState (gtk_dialog_set_default_response dialog (toInt ResponseAccept)) >>|
	run dialog
where
	buttons = map (\(s,r) -> (s,toInt r)) case action of
		OpenAction         -> [("Cancel", ResponseCancel), ("Open",   ResponseAccept)]
		SaveAction         -> [("Cancel", ResponseCancel), ("Save",   ResponseAccept)]
		SelectFolderAction -> [("Cancel", ResponseCancel), ("Select", ResponseAccept)]
		CreateFolderAction -> [("Cancel", ResponseCancel), ("Create", ResponseAccept)]

	run dialog =
		runDialog dialog >>= \response -> case response of
			ResponseAccept ->
				toStateR (gtk_file_chooser_get_filename dialog) >>= \file_name -> case file_name of
					Just _  -> destroy dialog >>| pure file_name
					Nothing -> run dialog
			_ ->
				destroy dialog >>|
				pure Nothing

:: GtkFrame :== Pointer

instance gtkWidget GtkFrame where gtkWidget f = f
instance gtkContainer GtkFrame where gtkContainer f = f
instance ptr GtkFrame
where
	toPtr   f = f
	fromPtr f = f

newFrame :: !GtkTitle !w -> GtkM GtkFrame | gtkWidget w
newFrame (Title title) widget =
	toStateR (gtk_frame_new (case title of "" -> Nothing; _ -> Just title)) >>= \frame ->
	(case title of
		"" -> pure ()
		_  -> toState (gtk_frame_set_label_align frame 0.02 0.5)) >>|
	addToContainer frame widget >>|
	show frame

framed :: !GtkTitle !(GtkM w) -> GtkM (w, GtkFrame) | gtkWidget w
framed title widgetf =
	widgetf >>= \widget ->
	tuple widget <$> newFrame title widget

:: GtkGrid :== Pointer

instance gtkWidget GtkGrid where gtkWidget g = g

newGrid :: GtkM GtkGrid
newGrid = toStateR gtk_grid_new >>= show

attachGrid :: !GtkGrid !(!Int,!Int) !(!Int,!Int) !w -> GtkM w | gtkWidget w
attachGrid grid (left,top) (width,height) widget =
	toState (gtk_grid_attach grid (gtkWidget widget) left top width height) >>|
	pure widget

:: GtkLabel :== Pointer

instance gtkWidget GtkLabel where gtkWidget l = l

newLabel :: GtkM GtkLabel
newLabel = toStateR gtk_label_new >>= show

instance tune GtkLabel GtkText
where
	tune (Text text) label =
		toState (gtk_label_set_markup label text) >>|
		pure label

:: GtkListStore :== Pointer

newListStore :: ![GType] -> GtkM GtkListStore
newListStore types = toStateR (gtk_list_store_newv {toInt t \\ t <- types})

clearListStore :: !GtkListStore -> GtkM GtkListStore
clearListStore store =
	toState (gtk_list_store_clear store) >>|
	pure store

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 ()

swapItems :: !Int !Int !GtkListStore -> GtkM Bool
swapItems a b store =
	let
		(ok_a,iter_a) = gtk_tree_model_get_iter_from_string store (toString a)
		(ok_b,iter_b) = gtk_tree_model_get_iter_from_string store (toString b)
	in
	if (ok_a && ok_b)
		(toState (gtk_list_store_swap store iter_a iter_b) >>| pure True)
		(pure False)

:: GtkMenu :== Pointer

instance gtkWidget GtkMenu where gtkWidget m = m

newMenu :: GtkM GtkMenu
newMenu = toStateR gtk_menu_new >>= show

:: GtkMenuBar :== Pointer

instance gtkWidget GtkMenuBar where gtkWidget mb = mb

newMenuBar :: GtkM GtkMenuBar
newMenuBar = toStateR gtk_menu_bar_new >>= show

:: GtkMenuItem :== Pointer

instance gtkWidget GtkMenuItem where gtkWidget mi = mi
instance gtkMenuItem GtkMenuItem where gtkMenuItem mi = mi

newMenuItem :: !String -> GtkM GtkMenuItem
newMenuItem label =
	toStateR gtk_menu_item_new >>= \item ->
	toState (gtk_menu_item_set_label item label) >>|
	toState (gtk_menu_item_set_use_underline item True) >>|
	show item

setSubMenu :: !mi !GtkMenu -> GtkM GtkMenu | gtkMenuItem mi
setSubMenu item menu =
	toState (gtk_menu_item_set_submenu (gtkMenuItem item) menu) >>|
	pure menu

:: GtkCheckMenuItem :== Pointer

instance gtkWidget GtkCheckMenuItem where gtkWidget cmi = cmi
instance gtkMenuItem GtkCheckMenuItem where gtkMenuItem cmi = cmi
instance ptr GtkCheckMenuItem
where
	toPtr   cmi = cmi
	fromPtr cmi = cmi

newCheckMenuItem :: !String -> GtkM GtkCheckMenuItem
newCheckMenuItem label =
	toStateR gtk_check_menu_item_new >>= \item ->
	toState (gtk_menu_item_set_label item label) >>|
	toState (gtk_menu_item_set_use_underline item True) >>|
	show item

isActive :: !GtkCheckMenuItem -> GtkM Bool
isActive item = toStateR (gtk_check_menu_item_get_active item)

setActive :: !Bool !GtkCheckMenuItem -> GtkM GtkCheckMenuItem
setActive active item =
	toState (gtk_check_menu_item_set_active item active) >>|
	pure item

:: GtkMenuShell :== Pointer

instance gtkWidget GtkMenuShell where gtkWidget ms = ms

instance gtkMenuShell GtkMenu where gtkMenuShell m = m
instance gtkMenuShell GtkMenuBar where gtkMenuShell mb = mb
instance gtkMenuShell GtkMenuShell where gtkMenuShell ms = ms

appendToMenuShell :: !s !mi -> GtkM mi | gtkMenuShell s & gtkMenuItem mi
appendToMenuShell shell item =
	toState (gtk_menu_shell_append (gtkMenuShell shell) (gtkMenuItem item)) >>|
	pure item

:: GtkOrientable :== Pointer

instance tune o GtkOrientation | gtkOrientable o
where
	tune orientation orientable =
		toState (gtk_orientable_set_orientation (gtkOrientable orientable) orientation=:Vertical) >>|
		pure orientable

:: GtkPaned :== Pointer

instance gtkWidget GtkPaned where gtkWidget p = p
instance gtkContainer GtkPaned where gtkContainer p = p

newPaned :: !GtkOrientation !GtkPanedHandleWidth -> GtkM GtkPaned
newPaned orientation handle_width =
	toStateR (gtk_paned_new orientation=:Vertical) >>= \paned ->
	toState (gtk_paned_set_wide_handle paned handle_width=:WideHandle) >>|
	show paned

packPane1 :: !GtkPaned !GtkResize !GtkShrink !w -> GtkM w | gtkWidget w
packPane1 paned resize shrink widget =
	toState (gtk_paned_pack1 paned (gtkWidget widget) resize=:Resize shrink=:Shrink) >>|
	pure widget

packPane2 :: !GtkPaned !GtkResize !GtkShrink !w -> GtkM w | gtkWidget w
packPane2 paned resize shrink widget =
	toState (gtk_paned_pack2 paned (gtkWidget widget) resize=:Resize shrink=:Shrink) >>|
	pure widget

:: GtkScrolledWindow :== Pointer

instance gtkWidget GtkScrolledWindow where gtkWidget sw = sw
instance gtkContainer GtkScrolledWindow where gtkContainer sw = sw

newScrolledWindow :: GtkM GtkScrolledWindow
newScrolledWindow = toStateR (gtk_scrolled_window_new 0 0) >>= show

instance tune GtkScrolledWindow (GtkScrollbarPolicy, GtkScrollbarPolicy)
where
	tune (hp,vp) window =
		toState (gtk_scrolled_window_set_policy window (toInt hp) (toInt vp)) >>|
		pure window

:: GtkSeparator :== Pointer

instance gtkWidget GtkSeparator where gtkWidget s = s
instance ptr GtkSeparator
where
	toPtr   s = s
	fromPtr s = s

newSeparator :: !GtkOrientation -> GtkM GtkSeparator
newSeparator orientation = toStateR (gtk_separator_new orientation=:Vertical) >>= show

:: GtkSpinner :== Pointer

instance gtkWidget GtkSpinner where gtkWidget s = s
instance ptr GtkSpinner
where
	toPtr   s = s
	fromPtr s = s

newSpinner :: GtkM GtkSpinner
newSpinner = toStateR gtk_spinner_new >>= show

startSpinner :: !GtkSpinner -> GtkM GtkSpinner
startSpinner spinner = toState (gtk_spinner_start spinner) >>| pure spinner

stopSpinner :: !GtkSpinner -> GtkM GtkSpinner
stopSpinner spinner = toState (gtk_spinner_stop spinner) >>| pure spinner

:: GtkTextBuffer :== Pointer

instance ptr GtkTextBuffer
where
	toPtr   b = b
	fromPtr b = b

setText :: !String !GtkTextBuffer -> GtkM GtkTextBuffer
setText s buffer =
	toState (gtk_text_buffer_set_text buffer s (size s)) >>|
	pure buffer

setMarkup :: !String !GtkTextBuffer -> GtkM GtkTextBuffer
setMarkup s buffer =
	toStateR (gtk_text_buffer_get_start_iter buffer) >>= \start ->
	toStateR (gtk_text_buffer_get_end_iter buffer) >>= \end ->
	toState (gtk_text_buffer_delete buffer start end) >>|
	toStateR (gtk_text_buffer_get_start_iter buffer) >>= \start ->
	toState (gtk_text_buffer_insert_markup buffer start s) >>|
	pure buffer

insertAtCursor :: !String !GtkTextBuffer -> GtkM GtkTextBuffer
insertAtCursor s buffer =
	toState (gtk_text_buffer_insert_at_cursor buffer s (size s)) >>|
	pure buffer

:: GtkTextView :== Pointer

instance gtkWidget GtkTextView where gtkWidget tv = tv
instance gtkContainer GtkTextView where gtkContainer tv = tv
instance ptr GtkTextView
where
	toPtr   tv = tv
	fromPtr tv = tv

newTextView :: GtkM GtkTextView
newTextView =
	toStateR gtk_text_view_new >>= \text_view ->
	toState (gtk_text_view_set_editable text_view False) >>|
	show text_view

getTextBuffer :: !GtkTextView -> GtkTextBuffer
getTextBuffer text_view = gtk_text_view_get_buffer text_view

instance tune GtkTextView GtkWrapMode
where
	tune mode text_view =
		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) >>= \view ->
	toState (g_object_unref store) >>|
	show view

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

addSelectionChangedHandler :: !(GtkM ()) !GtkTreeView -> GtkM GtkTreeView
addSelectionChangedHandler handler tree =
	let selection = gtk_tree_view_get_selection tree in
	tune (ChangedHandler handler) selection >>|
	pure tree

getPathToSelection :: !GtkTreeView -> GtkM (Maybe [Int])
getPathToSelection tree =
	let selection = gtk_tree_view_get_selection tree in
	toStateR (gtk_tree_selection_get_selected selection) >>= \(selected,iter)
		| not selected ->
			pure Nothing
		| otherwise ->
			let
				model = gtk_tree_view_get_model tree
				path = gtk_tree_model_get_string_from_iter model iter
			in
			pure (Just [toInt part \\ part <- split ":" path])

selectPath :: ![Int] !GtkTreeView -> GtkM Bool
selectPath path tree =
	let
		store = gtk_tree_view_get_model tree
		selection = gtk_tree_view_get_selection tree
		(ok,iter) = gtk_tree_model_get_iter_from_string store ('Text'.join ":" [toString i \\ i <- path])
	in
	if ok
		(toState (gtk_tree_selection_select_iter selection iter) >>| pure True)
		(pure False)

:: GtkWidget :== Pointer

instance gtkWidget GtkWidget where gtkWidget w = w

instance ptr GtkWidget
where
	toPtr   w = w
	fromPtr w = w

show :: !w -> GtkM w | gtkWidget w
show widget = toState (gtk_widget_show (gtkWidget widget)) >>| pure widget

hide :: !w -> GtkM w | gtkWidget w
hide widget = toState (gtk_widget_hide (gtkWidget widget)) >>| pure widget

destroy :: !w -> GtkM () | gtkWidget w
destroy widget = toState (gtk_widget_destroy (gtkWidget widget))

addCSSClass :: !GtkCSSClass !w -> GtkM w | gtkWidget w
addCSSClass (Class cls) widget =
	toStateR (gtk_widget_get_style_context (gtkWidget widget)) >>= \context ->
	toState (gtk_style_context_add_class context cls) >>|
	pure widget

removeCSSClass :: !GtkCSSClass !w -> GtkM () | gtkWidget w
removeCSSClass (Class cls) widget =
	toStateR (gtk_widget_get_style_context (gtkWidget widget)) >>= \context ->
	toState (gtk_style_context_remove_class context cls)

setMargins :: !GtkMargins !w -> GtkM w | gtkWidget w
setMargins {left,top,right,bottom} widget` =
	let widget = gtkWidget widget` in
	toState (gtk_widget_set_margin_left   widget left)   >>|
	toState (gtk_widget_set_margin_top    widget top)    >>|
	toState (gtk_widget_set_margin_right  widget right)  >>|
	toState (gtk_widget_set_margin_bottom widget bottom) >>|
	pure widget`

instance tune w GtkSensitivity | gtkWidget w
where
	tune sens widget =
		toState (gtk_widget_set_sensitive (gtkWidget widget) sens=:Sensitive) >>|
		pure widget

instance tune w (GtkAlign,GtkAlign) | gtkWidget w
where
	tune (halign,valign) widget =
		let ptr = gtkWidget widget in
		toState (gtk_widget_set_halign ptr (toInt halign)) >>|
		toState (gtk_widget_set_valign ptr (toInt valign)) >>|
		pure widget

:: GtkWindow :== Pointer

instance gtkWidget GtkWindow where gtkWidget w = w
instance gtkContainer GtkWindow where gtkContainer w = w
instance gtkWindow GtkWindow where gtkWindow w = w

newPopup :: !(Maybe (Int,Int)) -> GtkM GtkWindow
newPopup size = new_window_or_popup True size

newWindow :: !(Maybe (Int,Int)) -> GtkM GtkWindow
newWindow size = new_window_or_popup False size

new_window_or_popup :: !Bool !(Maybe (Int,Int)) -> GtkM GtkWindow
new_window_or_popup is_popup size =
	toStateR (gtk_window_new is_popup) >>= \window ->
	(case size of
		Nothing    -> pure ()
		Just (h,v) -> toState (gtk_widget_set_size_request window h v)) >>|
	show window

instance tune w GtkTitle | gtkWindow w
where
	tune (Title s) window =
		toState (gtk_window_set_title (gtkWindow window) s) >>|
		pure 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 gtk_css_provider_new >>= \provider ->
	toStateR (gtk_css_provider_load_from_path provider path 0) >>= \ok
		| not ok -> pure ok
		| otherwise ->
			toStateR (gtk_widget_get_screen window) >>= \screen ->
			toState (gtk_style_context_add_provider_for_screen screen provider (toInt priority)) >>|
			pure True