summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Gtk/Internal.dcl13
-rw-r--r--src/Gtk/Internal.icl86
-rw-r--r--src/Gtk/Types.dcl27
-rw-r--r--src/Gtk/Types.icl40
-rw-r--r--src/Gtk/Widgets.dcl22
-rw-r--r--src/Gtk/Widgets.icl48
6 files changed, 227 insertions, 9 deletions
diff --git a/src/Gtk/Internal.dcl b/src/Gtk/Internal.dcl
index 31a50c9..53f3366 100644
--- a/src/Gtk/Internal.dcl
+++ b/src/Gtk/Internal.dcl
@@ -8,6 +8,8 @@ from System._Pointer import :: Pointer
{ sig_id :: !Int
}
+g_free :: !Pointer !.a -> .a
+
g_object_unref :: !Pointer !.a -> .a
g_signal_connect_void :: !Pointer !String !Int !.a -> .a
@@ -22,6 +24,16 @@ 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_dialog_run :: !Pointer !.a -> (!Int, !.a)
+gtk_dialog_set_default_response :: !Pointer !Int !.a -> .a
+
+gtk_file_chooser_add_filter :: !Pointer !Pointer !.a -> .a
+gtk_file_chooser_dialog_new :: !(Maybe String) !Pointer !Int ![(String,Int)] !.a -> (!Pointer, !.a)
+gtk_file_chooser_get_filename :: !Pointer !.a -> (!Maybe String, !.a)
+
+gtk_file_filter_new :: !.a -> (!Pointer, !.a)
+gtk_file_filter_add_pattern :: !Pointer !String !.a -> .a
+
gtk_frame_new :: !(Maybe String) !.a -> (!Pointer, !.a)
gtk_frame_set_label_align :: !Pointer !Real !Real !.a -> .a
@@ -59,6 +71,7 @@ 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_destroy :: !Pointer !.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
diff --git a/src/Gtk/Internal.icl b/src/Gtk/Internal.icl
index 8704e35..787a2c9 100644
--- a/src/Gtk/Internal.icl
+++ b/src/Gtk/Internal.icl
@@ -2,11 +2,17 @@ implementation module Gtk.Internal
import StdEnv
import StdMaybe
+import StdDebug
import System._Pointer
import code from "clean_gtk_support."
+g_free :: !Pointer !.a -> .a
+g_free p env = code {
+ ccall g_free "p:V:A"
+}
+
g_object_unref :: !Pointer !.a -> .a
g_object_unref p env = code {
ccall g_object_unref "p:V:A"
@@ -70,6 +76,81 @@ where
ccall gtk_css_provider_load_from_path "psp:I:A"
}
+gtk_dialog_run :: !Pointer !.a -> (!Int, !.a)
+gtk_dialog_run dialog env = code {
+ ccall gtk_dialog_run "p:I:A"
+}
+
+gtk_dialog_set_default_response :: !Pointer !Int !.a -> .a
+gtk_dialog_set_default_response dialog response env = code {
+ ccall gtk_dialog_set_default_response "pI:V:A"
+}
+
+gtk_file_chooser_add_filter :: !Pointer !Pointer !.a -> .a
+gtk_file_chooser_add_filter chooser filter env = code {
+ ccall gtk_file_chooser_add_filter "pp:V:A"
+}
+
+gtk_file_chooser_dialog_new :: !(Maybe String) !Pointer !Int ![(String,Int)] !.a -> (!Pointer, !.a)
+gtk_file_chooser_dialog_new (Just title) parent action [(button,response)] env =
+ new (packString title) parent action (packString button) response 0 env
+where
+ new :: !String !Pointer !Int !String !Int !Pointer !.a -> (!Pointer, !.a)
+ new _ _ _ _ _ _ _ = code {
+ ccall gtk_file_chooser_dialog_new "spIsIp:p:A"
+ }
+gtk_file_chooser_dialog_new (Just title) parent action [(b1,r1),(b2,r2)] env =
+ new (packString title) parent action (packString b1) r1 (packString b2) r2 0 env
+where
+ new :: !String !Pointer !Int !String !Int !String !Int !Pointer !.a -> (!Pointer, !.a)
+ new _ _ _ _ _ _ _ _ _ = code {
+ ccall gtk_file_chooser_dialog_new "spIsIsIp:p:A"
+ }
+gtk_file_chooser_dialog_new Nothing parent action [(button,response)] env =
+ new 0 parent action (packString button) response 0 env
+where
+ new :: !Pointer !Pointer !Int !String !Int !Pointer !.a -> (!Pointer, !.a)
+ new _ _ _ _ _ _ _ = code {
+ ccall gtk_file_chooser_dialog_new "ppIsIp:p:A"
+ }
+gtk_file_chooser_dialog_new Nothing parent action [(b1,r1),(b2,r2)] env =
+ new 0 parent action (packString b1) r1 (packString b2) r2 0 env
+where
+ new :: !Pointer !Pointer !Int !String !Int !String !Int !Pointer !.a -> (!Pointer, !.a)
+ new _ _ _ _ _ _ _ _ _ = code {
+ ccall gtk_file_chooser_dialog_new "ppIsIsIp:p:A"
+ }
+gtk_file_chooser_dialog_new _ _ _ buttons env =
+ trace_n
+ ("gtk_file_chooser_dialog_new: "+++toString (length buttons)+++" buttons not supported")
+ (0, env)
+
+gtk_file_chooser_get_filename :: !Pointer !.a -> (!Maybe String, !.a)
+gtk_file_chooser_get_filename chooser env
+ # (filename,env) = get chooser env
+ | filename == 0 = (Nothing, env)
+ # (filename_string,filename) = readP derefString filename
+ # env = g_free filename env
+ = (Just filename_string, env)
+where
+ get :: !Pointer !.a -> (!Pointer, !.a)
+ get _ _ = code {
+ ccall gtk_file_chooser_get_filename "p:p:A"
+ }
+
+gtk_file_filter_new :: !.a -> (!Pointer, !.a)
+gtk_file_filter_new env = code {
+ ccall gtk_file_filter_new ":p:A"
+}
+
+gtk_file_filter_add_pattern :: !Pointer !String !.a -> .a
+gtk_file_filter_add_pattern filter pattern env = add filter (packString pattern) env
+where
+ add :: !Pointer !String !.a -> .a
+ add _ _ _ = code {
+ ccall gtk_file_filter_add_pattern "ps:V:A"
+ }
+
gtk_frame_new :: !(Maybe String) !.a -> (!Pointer, !.a)
gtk_frame_new Nothing env = new 0 env
where
@@ -216,6 +297,11 @@ gtk_text_view_set_editable text_view setting env = code {
ccall gtk_text_view_set_editable "pI:V:A"
}
+gtk_widget_destroy :: !Pointer !.a -> .a
+gtk_widget_destroy widget env = code {
+ ccall gtk_widget_destroy "p: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"
diff --git a/src/Gtk/Types.dcl b/src/Gtk/Types.dcl
index fda694b..836bdaa 100644
--- a/src/Gtk/Types.dcl
+++ b/src/Gtk/Types.dcl
@@ -1,6 +1,6 @@
definition module Gtk.Types
-from StdOverloaded import class toInt
+from StdOverloaded import class fromInt, class toInt
:: GtkCSSClass
= Class !String
@@ -13,6 +13,14 @@ from StdOverloaded import class toInt
= Expand
| NoExpand
+:: GtkFileChooserAction
+ = OpenAction
+ | SaveAction
+ | SelectFolderAction
+ | CreateFolderAction
+
+instance toInt GtkFileChooserAction
+
:: GtkLabel
= Label !String
| NoLabel
@@ -38,6 +46,23 @@ margin :: !Int -> GtkMargins
= Resize
| NoResize
+:: GtkResponse
+ = ResponseNone
+ | ResponseReject
+ | ResponseAccept
+ | ResponseDeleteEvent
+ | ResponseOk
+ | ResponseCancel
+ | ResponseClose
+ | ResponseYes
+ | ResponseNo
+ | ResponseApply
+ | ResponseHelp
+
+//* Illegal values map to `ResponseNone`.
+instance fromInt GtkResponse
+instance toInt GtkResponse
+
:: GtkShrink
= Shrink
| NoShrink
diff --git a/src/Gtk/Types.icl b/src/Gtk/Types.icl
index f8fa6cc..3badaa0 100644
--- a/src/Gtk/Types.icl
+++ b/src/Gtk/Types.icl
@@ -1,6 +1,15 @@
implementation module Gtk.Types
import StdEnv
+import StdDebug
+
+instance toInt GtkFileChooserAction
+where
+ toInt action = case action of
+ OpenAction -> 0
+ SaveAction -> 1
+ SelectFolderAction -> 2
+ CreateFolderAction -> 3
margin :: !Int -> GtkMargins
margin n =
@@ -10,6 +19,37 @@ margin n =
, bottom = n
}
+instance fromInt GtkResponse
+where
+ fromInt response = case response of
+ 0 -> ResponseNone
+ 1 -> ResponseReject
+ 2 -> ResponseAccept
+ 3 -> ResponseDeleteEvent
+ 4 -> ResponseOk
+ 5 -> ResponseCancel
+ 6 -> ResponseClose
+ 7 -> ResponseYes
+ 8 -> ResponseNo
+ 9 -> ResponseApply
+ 10 -> ResponseHelp
+ r -> trace_n ("fromInt GtkResponse: illegal value "+++toString r) ResponseNone
+
+instance toInt GtkResponse
+where
+ toInt response = case response of
+ ResponseNone -> 0
+ ResponseReject -> 1
+ ResponseAccept -> 2
+ ResponseDeleteEvent -> 3
+ ResponseOk -> 4
+ ResponseCancel -> 5
+ ResponseClose -> 6
+ ResponseYes -> 7
+ ResponseNo -> 8
+ ResponseApply -> 9
+ ResponseHelp -> 10
+
instance toInt GtkStylePriority
where
toInt prio = case prio of
diff --git a/src/Gtk/Widgets.dcl b/src/Gtk/Widgets.dcl
index 2403b40..55a6ad4 100644
--- a/src/Gtk/Widgets.dcl
+++ b/src/Gtk/Widgets.dcl
@@ -7,8 +7,9 @@ from System._Pointer import :: Pointer
from Gtk.State import :: State, :: StateT, :: Identity, :: GtkState, :: GtkM
from Gtk.Types import :: GtkCSSClass, :: GtkDirection, :: GtkExpand,
- :: GtkLabel, :: GtkMargins, :: GtkOrientation, :: GtkPanedHandleWidth,
- :: GtkResize, :: GtkShrink, :: GtkStylePriority
+ :: GtkFileChooserAction, :: GtkLabel, :: GtkMargins, :: GtkOrientation,
+ :: GtkPanedHandleWidth, :: GtkResize, :: GtkResponse, :: GtkShrink,
+ :: GtkStylePriority
class ptr a
where
@@ -22,10 +23,12 @@ class gtkWidget a :: !a -> GtkWidget
instance gtkWidget GtkWidget
instance ptr GtkWidget
+show :: !w -> GtkM w | gtkWidget w
+destroy :: !w -> GtkM () | gtkWidget w
+
addCSSClass :: !GtkCSSClass !w -> GtkM w | gtkWidget w
removeCSSClass :: !GtkCSSClass !w -> GtkM () | gtkWidget w
setMargins :: !GtkMargins !w -> GtkM w | gtkWidget w
-show :: !w -> GtkM w | gtkWidget w
:: GtkContainer
@@ -37,6 +40,19 @@ instance ptr GtkContainer
addToContainer :: !c !w -> GtkM w | gtkWidget w & gtkContainer c
+:: GtkDialog
+
+class gtkDialog a :: !a -> GtkDialog
+
+instance gtkWidget GtkDialog
+instance gtkContainer GtkDialog
+instance gtkDialog GtkDialog
+instance ptr GtkDialog
+
+runDialog :: !d -> GtkM GtkResponse | gtkDialog d
+
+getFileWithDialog :: !GtkWindow !GtkFileChooserAction !(Maybe String) -> GtkM (Maybe FilePath)
+
:: GtkBox
instance gtkWidget GtkBox
instance gtkContainer GtkBox
diff --git a/src/Gtk/Widgets.icl b/src/Gtk/Widgets.icl
index 117fa49..5c8f1e6 100644
--- a/src/Gtk/Widgets.icl
+++ b/src/Gtk/Widgets.icl
@@ -11,9 +11,8 @@ import Data.Tuple
import System.FilePath
import System._Pointer
+import Gtk
import Gtk.Internal
-import Gtk.State
-import Gtk.Types
:: GtkWidget :== Pointer
@@ -24,6 +23,12 @@ 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 ->
@@ -44,9 +49,6 @@ setMargins {left,top,right,bottom} widget` =
toState (gtk_widget_set_margin_bottom widget bottom) >>|
pure widget`
-show :: !w -> GtkM w | gtkWidget w
-show widget = toState (gtk_widget_show (gtkWidget widget)) >>| pure widget
-
:: GtkContainer :== Pointer
instance gtkWidget GtkContainer where gtkWidget c = c
@@ -62,6 +64,42 @@ 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
+
+runDialog :: !d -> GtkM GtkResponse | gtkDialog d
+runDialog dialog = fromInt <$> toStateR (gtk_dialog_run (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
+
:: GtkBox :== Pointer
instance gtkWidget GtkBox where gtkWidget b = b
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-01 12:07:34 +0000