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

import Gtk
import Gtk.Internal

:: GtkBox :== Pointer

instance gtkWidget GtkBox where gtkWidget b = b
instance gtkContainer GtkBox where gtkContainer 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

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

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

newFrame :: !GtkLabel !w -> GtkM GtkFrame | gtkWidget w
newFrame label widget =
	toStateR (gtk_frame_new (case label of Label l -> Just l; _ -> Nothing)) >>= \frame ->
	(case label of
		Label _ -> toState (gtk_frame_set_label_align frame 0.02 0.5)
		NoLabel -> pure ()) >>|
	addToContainer frame widget >>|
	show frame

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

:: 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

:: 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

:: GtkSpinner :== Pointer

instance gtkWidget GtkSpinner where gtkWidget 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

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

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

:: 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

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`

:: GtkWindow :== Pointer

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

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

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

new_window_or_popup :: !Bool !String !(Maybe (Int,Int)) -> GtkM GtkWindow
new_window_or_popup is_popup title size =
	toStateR (gtk_window_new is_popup) >>= \window ->
	toState (gtk_window_set_title window title) >>|
	(case size of
		Nothing    -> pure ()
		Just (h,v) -> toState (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 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