summaryrefslogtreecommitdiff
path: root/src/Gtk
diff options
context:
space:
mode:
Diffstat (limited to 'src/Gtk')
-rw-r--r--src/Gtk/Internal.dcl25
-rw-r--r--src/Gtk/Internal.icl77
-rw-r--r--src/Gtk/Signal.dcl14
-rw-r--r--src/Gtk/Signal.icl26
-rw-r--r--src/Gtk/State.dcl28
-rw-r--r--src/Gtk/State.icl57
-rw-r--r--src/Gtk/Widgets.dcl20
-rw-r--r--src/Gtk/Widgets.icl41
8 files changed, 288 insertions, 0 deletions
diff --git a/src/Gtk/Internal.dcl b/src/Gtk/Internal.dcl
new file mode 100644
index 0000000..14bb9ab
--- /dev/null
+++ b/src/Gtk/Internal.dcl
@@ -0,0 +1,25 @@
+definition module Gtk.Internal
+
+from StdMaybe import :: Maybe
+
+from System._Pointer import :: Pointer
+
+:: GSignalArgs =
+ { sig_id :: !Int
+ }
+
+g_object_unref :: !Pointer !.a -> .a
+
+g_signal_connect_void :: !Pointer !String !Int !.a -> .a
+g_signal_pop :: !.a -> (!Maybe GSignalArgs, !.a)
+
+gtk_init :: !.a -> .a
+
+gtk_main_iteration :: !.a -> (!Bool, !.a)
+gtk_main_quit :: !.a -> .a
+
+gtk_widget_set_size_request :: !Pointer !Int !Int !.a -> .a
+gtk_widget_show_all :: !Pointer !.a -> .a
+
+gtk_window_new :: !Bool !.a -> (!Pointer, !.a)
+gtk_window_set_title :: !Pointer !String !.a -> .a
diff --git a/src/Gtk/Internal.icl b/src/Gtk/Internal.icl
new file mode 100644
index 0000000..827cae6
--- /dev/null
+++ b/src/Gtk/Internal.icl
@@ -0,0 +1,77 @@
+implementation module Gtk.Internal
+
+import StdEnv
+import StdMaybe
+
+import System._Pointer
+
+import code from "clean_gtk_support."
+
+g_object_unref :: !Pointer !.a -> .a
+g_object_unref p env = code {
+ ccall g_object_unref "p:V:A"
+}
+
+g_signal_connect_void :: !Pointer !String !Int !.a -> .a
+g_signal_connect_void widget signal id env = connect widget (packString signal) id env
+where
+ connect :: !Pointer !String !Int !.a -> .a
+ connect _ _ _ _ = code {
+ ccall clean_g_signal_connect_void "psI:V:A"
+ }
+
+g_signal_pop :: !.a -> (!Maybe GSignalArgs, !.a)
+g_signal_pop env
+ # (sig,env) = pop env
+ | sig == 0
+ = (Nothing, env)
+ # (id,sig) = readIntP sig (IF_INT_64_OR_32 8 4)
+ | sig == 0 // force evaluation
+ = abort "Internal error in g_signal_pop\n"
+ = (Just {sig_id=id}, env)
+where
+ pop :: !.a -> (!Pointer, !.a)
+ pop env = code {
+ ccall clean_g_signal_pop ":p:A"
+ }
+
+gtk_init :: !.a -> .a
+gtk_init env = init 0 0 env
+where
+ init :: !Pointer !Pointer !.a -> .a
+ init argc argv env = code {
+ ccall gtk_init "pp:V:A"
+ }
+
+gtk_main_iteration :: !.a -> (!Bool, !.a)
+gtk_main_iteration env = code {
+ ccall gtk_main_iteration ":I:A"
+}
+
+gtk_main_quit :: !.a -> .a
+gtk_main_quit env = code {
+ ccall gtk_main_quit ":V:A"
+}
+
+gtk_widget_set_size_request :: !Pointer !Int !Int !.a -> .a
+gtk_widget_set_size_request widget hsize vsize env = code {
+ ccall gtk_widget_set_size_request "pII:V:A"
+}
+
+gtk_widget_show_all :: !Pointer !.a -> .a
+gtk_widget_show_all widget env = code {
+ ccall gtk_widget_show_all "p:V:A"
+}
+
+gtk_window_new :: !Bool !.a -> (!Pointer, !.a)
+gtk_window_new is_popup env = code {
+ ccall gtk_window_new "I:p:A"
+}
+
+gtk_window_set_title :: !Pointer !String !.a -> .a
+gtk_window_set_title window title env = set window (packString title) env
+where
+ set :: !Pointer !String !.a -> .a
+ set _ _ _ = code {
+ ccall gtk_window_set_title "ps:V:A"
+ }
diff --git a/src/Gtk/Signal.dcl b/src/Gtk/Signal.dcl
new file mode 100644
index 0000000..10e6ef7
--- /dev/null
+++ b/src/Gtk/Signal.dcl
@@ -0,0 +1,14 @@
+definition module Gtk.Signal
+
+from Gtk.State import :: State, :: StateT, :: Identity, :: GtkState
+from Gtk.Widgets import class gtkWidget
+
+:: GSignalHandlerFunction :== State GtkState ()
+
+:: GSignalHandler
+ = DestroyHandler !GSignalHandlerFunction
+
+:: GSignalHandlerInternal
+ = GSHI_Void !GSignalHandlerFunction
+
+installSignalHandler :: !w !GSignalHandler -> State GtkState () | gtkWidget w
diff --git a/src/Gtk/Signal.icl b/src/Gtk/Signal.icl
new file mode 100644
index 0000000..4bc14b5
--- /dev/null
+++ b/src/Gtk/Signal.icl
@@ -0,0 +1,26 @@
+implementation module Gtk.Signal
+
+import StdEnv
+
+import Control.Monad
+import Control.Monad.Identity
+import Control.Monad.State
+import qualified Data.Map as M
+
+import qualified Gtk.Internal as I
+import Gtk.State
+import Gtk.Widgets
+
+installSignalHandler :: !w !GSignalHandler -> State GtkState () | gtkWidget w
+installSignalHandler widget handler =
+ modify (\st ->
+ { st
+ & signal_handlers = 'M'.put (st.signal_counter+1) handler_internal st.signal_handlers
+ , signal_counter = st.signal_counter+1
+ }) >>|
+ gets (\st -> st.signal_counter) >>= \id ->
+ toState case handler_internal of
+ GSHI_Void _ -> 'I'.g_signal_connect_void (gtkPtr widget) signal_name id
+where
+ (signal_name,handler_internal) = case handler of
+ DestroyHandler f -> ("destroy",GSHI_Void f)
diff --git a/src/Gtk/State.dcl b/src/Gtk/State.dcl
new file mode 100644
index 0000000..d750900
--- /dev/null
+++ b/src/Gtk/State.dcl
@@ -0,0 +1,28 @@
+definition module Gtk.State
+
+from StdMaybe import :: Maybe
+
+from Control.Applicative import class pure
+from Control.Monad.State import :: State, :: StateT,
+ instance pure (StateT m s)
+from Control.Monad.Identity import :: Identity,
+ instance pure Identity
+from Data.Map import :: Map
+
+from Gtk.Signal import :: GSignalHandlerInternal
+
+:: GtkState =
+ { world :: !()
+ , return :: !Bool
+ , signal_handlers :: !Map Int GSignalHandlerInternal
+ , signal_counter :: !Int
+ }
+
+newGtkState :: GtkState
+
+runGtk :: !(State GtkState a) !*World -> (!a, !*World)
+
+toState :: !(A.a: a -> a) -> State GtkState ()
+toStateR :: !(A.a: a -> (r,a)) -> State GtkState r
+
+quit :: State GtkState ()
diff --git a/src/Gtk/State.icl b/src/Gtk/State.icl
new file mode 100644
index 0000000..16312b2
--- /dev/null
+++ b/src/Gtk/State.icl
@@ -0,0 +1,57 @@
+implementation module Gtk.State
+
+import StdEnv
+
+import Control.Monad
+import Control.Monad.Identity
+import Control.Monad.State
+import qualified Data.Map as M
+from Data.Map import :: Map
+import Data.Maybe
+
+import qualified Gtk.Internal as I
+from Gtk.Internal import :: GSignalArgs{..}
+import Gtk.Signal
+
+newGtkState :: GtkState
+newGtkState =
+ { world = ()
+ , return = False
+ , signal_handlers = 'M'.newMap
+ , signal_counter = 0
+ }
+
+runGtk :: !(State GtkState a) !*World -> (!a, !*World)
+runGtk f w = (evalState wrapped_f newGtkState, w)
+where
+ wrapped_f =
+ toState 'I'.gtk_init >>|
+ f >>= \x ->
+ main >>|
+ pure x
+ main =
+ toStateR 'I'.gtk_main_iteration >>|
+ handle_signals >>|
+ gets (\st -> st.return) >>= \return
+ | return -> pure ()
+ | otherwise -> main
+ handle_signals =
+ toStateR 'I'.g_signal_pop >>= \sig_args -> case sig_args of
+ Nothing ->
+ pure ()
+ Just sig_args ->
+ gets (\st -> 'M'.get sig_args.sig_id st.signal_handlers) >>= \(Just handler) ->
+ run handler >>|
+ handle_signals
+ with
+ run handler = case handler of
+ GSHI_Void st -> st >>| handle_signals
+
+toState :: !(A.a: a -> a) -> State GtkState ()
+toState f = state \st -> let w = f st.world in ((), {st & world=w})
+
+toStateR :: !(A.a: a -> (r,a)) -> State GtkState r
+toStateR f = state \st -> let (r,w) = f st.world in (r, {st & world=w})
+
+quit :: State GtkState ()
+quit = modify \st -> {st & return=True}
diff --git a/src/Gtk/Widgets.dcl b/src/Gtk/Widgets.dcl
new file mode 100644
index 0000000..d27d70d
--- /dev/null
+++ b/src/Gtk/Widgets.dcl
@@ -0,0 +1,20 @@
+definition module Gtk.Widgets
+
+from StdMaybe import :: Maybe
+
+from System._Pointer import :: Pointer
+
+from Gtk.State import :: State, :: StateT, :: Identity, :: GtkState
+
+:: GtkWidget
+:: GtkWindow
+
+class gtkWidget a
+where
+ gtkWidget :: !a -> GtkWidget
+ gtkPtr :: !a -> Pointer
+
+instance gtkWidget GtkWidget, GtkWindow
+
+newPopup :: !String !(Maybe (Int,Int)) -> State GtkState GtkWindow
+newWindow :: !String !(Maybe (Int,Int)) -> State GtkState GtkWindow
diff --git a/src/Gtk/Widgets.icl b/src/Gtk/Widgets.icl
new file mode 100644
index 0000000..dfeb901
--- /dev/null
+++ b/src/Gtk/Widgets.icl
@@ -0,0 +1,41 @@
+implementation module Gtk.Widgets
+
+import StdEnv
+import StdMaybe
+
+import Control.Monad
+import Control.Monad.Identity
+import Control.Monad.State
+import System._Pointer
+
+import qualified Gtk.Internal as I
+import Gtk.State
+
+:: GtkWidget :== Int
+:: GtkWindow :== Int
+
+instance gtkWidget GtkWidget
+where
+ gtkWidget w = w
+ gtkPtr w = w
+
+instance gtkWidget GtkWindow
+where
+ gtkWidget w = w
+ gtkPtr w = w
+
+newPopup :: !String !(Maybe (Int,Int)) -> State GtkState GtkWindow
+newPopup title size = new_window_or_popup True title size
+
+newWindow :: !String !(Maybe (Int,Int)) -> State GtkState GtkWindow
+newWindow title size = new_window_or_popup False title size
+
+new_window_or_popup :: !Bool !String !(Maybe (Int,Int)) -> State GtkState GtkWindow
+new_window_or_popup is_popup title size =
+ toStateR ('I'.gtk_window_new is_popup) >>= \window ->
+ toState ('I'.gtk_window_set_title window title) >>|
+ (case size of
+ Nothing -> pure ()
+ Just (h,v) -> toState ('I'.gtk_widget_set_size_request window h v)) >>|
+ toState ('I'.gtk_widget_show_all window) >>|
+ pure window
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-01 10:49:17 +0000