summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore6
-rw-r--r--config/Gtk.linux.env19
-rw-r--r--config/Gtk.linux.prt51
-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
-rw-r--r--src/clean_gtk_support.c53
-rw-r--r--test/test.icl18
13 files changed, 435 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..61da44c
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,6 @@
+*.abc
+*.o
+
+*.prj
+
+test/test
diff --git a/config/Gtk.linux.env b/config/Gtk.linux.env
new file mode 100644
index 0000000..0122ec3
--- /dev/null
+++ b/config/Gtk.linux.env
@@ -0,0 +1,19 @@
+Version: 1.0
+Environments
+ Environment
+ EnvironmentName: Gtk
+ EnvironmentPaths
+ Path: {Application}/lib/StdEnv
+ EnvironmentCompiler: lib/exe/cocl
+ EnvironmentABCOptimise: lib/exe/abcopt
+ EnvironmentByteCodeGen: lib/exe/bcgen
+ EnvironmentByteCodeLink: lib/exe/bclink
+ EnvironmentByteCodeStrip: lib/exe/bcstrip
+ EnvironmentByteCodePrelink: lib/exe/bcprelink
+ EnvironmentCodeGen: lib/exe/cg
+ EnvironmentLinker: /usr/bin/gcc::-Wl,--gc-sections -lgtk-3 -lgdk-3 -lpangocairo-1.0 -lpango-1.0 -latk-1.0 -lcairo-object -lcairo -lgdk_pixbuf-2.0 -lgio-2.0 -lgobject-2.0 -lglib-2.0
+ EnvironmentVersion: 920
+ EnvironmentRedirect: False
+ EnvironmentCompileMethod: Pers
+ EnvironmentProcessor: I386
+ Environment64BitProcessor: True
diff --git a/config/Gtk.linux.prt b/config/Gtk.linux.prt
new file mode 100644
index 0000000..1b70e04
--- /dev/null
+++ b/config/Gtk.linux.prt
@@ -0,0 +1,51 @@
+Version: 1.5
+Global
+ ProjectRoot: .
+ Target: Gtk
+ CodeGen
+ CheckStacks: False
+ CheckIndexes: True
+ OptimiseABC: False
+ GenerateByteCode: False
+ Application
+ HeapSize: 2097152
+ StackSize: 512000
+ ExtraMemory: 8192
+ IntialHeapSize: 204800
+ HeapSizeMultiplier: 4096
+ ShowExecutionTime: False
+ ShowGC: False
+ ShowStackSize: False
+ MarkingCollector: False
+ DisableRTSFlags: False
+ StandardRuntimeEnv: True
+ Profile
+ Memory: False
+ MemoryMinimumHeapSize: 0
+ Time: False
+ Stack: False
+ Dynamics: False
+ GenericFusion: False
+ DescExL: False
+ Output
+ Output: ShowConstructors
+ Font: Courier
+ FontSize: 9
+ WriteStdErr: False
+ Link
+ LinkMethod: Static
+ GenerateRelocations: False
+ GenerateSymbolTable: False
+ GenerateLinkMap: False
+ LinkResources: False
+ ResourceSource:
+ GenerateDLL: False
+ ExportedNames:
+ StripByteCode: True
+ KeepByteCodeSymbols: True
+ PrelinkByteCode: True
+ Paths
+ Path: {Application}*lib*Platform
+ Path: {Application}*lib*Gtk
+ Precompile:
+ Postlink:
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 <gtk/gtk.h>
+
+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);
+}
diff --git a/test/test.icl b/test/test.icl
new file mode 100644
index 0000000..5717add
--- /dev/null
+++ b/test/test.icl
@@ -0,0 +1,18 @@
+module test
+
+import StdMaybe
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Identity
+import Control.Monad.State
+
+import Gtk.Signal
+import Gtk.State
+import Gtk.Widgets
+
+Start w = runGtk app w
+where
+ app =
+ newWindow "Hello!" Nothing >>= \window ->
+ installSignalHandler window (DestroyHandler quit)
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-01 04:05:17 +0000