From ad98343da1467653dacc811a9e52b7da2282c200 Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Sat, 19 Oct 2019 19:57:53 +0200 Subject: Initial commit --- src/Gtk/Internal.dcl | 25 ++++++++++++++++ src/Gtk/Internal.icl | 77 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Gtk/Signal.dcl | 14 +++++++++ src/Gtk/Signal.icl | 26 +++++++++++++++++ src/Gtk/State.dcl | 28 ++++++++++++++++++ src/Gtk/State.icl | 57 ++++++++++++++++++++++++++++++++++++ src/Gtk/Widgets.dcl | 20 +++++++++++++ src/Gtk/Widgets.icl | 41 ++++++++++++++++++++++++++ src/clean_gtk_support.c | 53 ++++++++++++++++++++++++++++++++++ 9 files changed, 341 insertions(+) create mode 100644 src/Gtk/Internal.dcl create mode 100644 src/Gtk/Internal.icl create mode 100644 src/Gtk/Signal.dcl create mode 100644 src/Gtk/Signal.icl create mode 100644 src/Gtk/State.dcl create mode 100644 src/Gtk/State.icl create mode 100644 src/Gtk/Widgets.dcl create mode 100644 src/Gtk/Widgets.icl create mode 100644 src/clean_gtk_support.c (limited to 'src') 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 diff --git a/src/clean_gtk_support.c b/src/clean_gtk_support.c new file mode 100644 index 0000000..c725dfd --- /dev/null +++ b/src/clean_gtk_support.c @@ -0,0 +1,53 @@ +#include + +typedef long CleanInt; + +void *safe_malloc(size_t n) { + void *ptr=malloc (n); + if (ptr==NULL) + perror ("malloc"); + return ptr; +} + +struct clean_g_signal { + GtkWidget *target; + CleanInt id; + struct clean_g_signal *next; +}; + +static struct clean_g_signal *signal_queue=NULL; +static struct clean_g_signal *last_signal=NULL; + +static struct clean_g_signal *clean_g_signal_push (void) { + struct clean_g_signal *signal=safe_malloc (sizeof(struct clean_g_signal)); + + if (last_signal!=NULL) + last_signal->next=signal; + else if (signal_queue==NULL) + signal_queue=signal; + + last_signal=signal; + + return signal; +} + +struct clean_g_signal *clean_g_signal_pop (void) { + struct clean_g_signal *signal=signal_queue; + + if (signal_queue==NULL) + last_signal=NULL; + + signal_queue=NULL; + + return signal; +} + +static void clean_g_signal_handler_void (GtkWidget *target,gpointer data) { + struct clean_g_signal *signal=clean_g_signal_push(); + signal->target=target; + signal->id=(CleanInt)data; +} + +void clean_g_signal_connect_void (GtkWidget *widget,char *signal,CleanInt id) { + g_signal_connect (widget,signal,G_CALLBACK (clean_g_signal_handler_void),(gpointer)id); +} -- cgit v1.2.3