summaryrefslogtreecommitdiff
path: root/src/Gtk
diff options
context:
space:
mode:
Diffstat (limited to 'src/Gtk')
-rw-r--r--src/Gtk/Signal.dcl4
-rw-r--r--src/Gtk/Signal.icl11
-rw-r--r--src/Gtk/State.dcl20
-rw-r--r--src/Gtk/State.icl71
-rw-r--r--src/Gtk/Tune.dcl2
-rw-r--r--src/Gtk/Tune.icl2
-rw-r--r--src/Gtk/Widgets.dcl2
-rw-r--r--src/Gtk/Widgets.icl2
-rw-r--r--src/Gtk/Widgets/Sheet.dcl8
-rw-r--r--src/Gtk/Widgets/Sheet.icl8
10 files changed, 85 insertions, 45 deletions
diff --git a/src/Gtk/Signal.dcl b/src/Gtk/Signal.dcl
index acec991..32ebc08 100644
--- a/src/Gtk/Signal.dcl
+++ b/src/Gtk/Signal.dcl
@@ -1,6 +1,6 @@
definition module Gtk.Signal
-from Gtk.State import :: State, :: StateT, :: Identity, :: GtkState, :: GtkM
+from Gtk.State import :: GtkM
from Gtk.Widgets import class gtkWidget
:: GSignalHandlerFunction :== GtkM ()
@@ -12,4 +12,4 @@ from Gtk.Widgets import class gtkWidget
:: GSignalHandlerInternal
= GSHI_Void !GSignalHandlerFunction
-installSignalHandler :: !GSignalHandler !w -> State GtkState w | gtkWidget w
+installSignalHandler :: !GSignalHandler !w -> GtkM w | gtkWidget w
diff --git a/src/Gtk/Signal.icl b/src/Gtk/Signal.icl
index 5861e92..119829a 100644
--- a/src/Gtk/Signal.icl
+++ b/src/Gtk/Signal.icl
@@ -3,22 +3,19 @@ implementation module Gtk.Signal
import StdEnv
import Control.Monad
-import Control.Monad.Identity
-import Control.Monad.State
import qualified Data.Map
+import Gtk
import Gtk.Internal
-import Gtk.State
-import Gtk.Widgets
-installSignalHandler :: !GSignalHandler !w -> State GtkState w | gtkWidget w
+installSignalHandler :: !GSignalHandler !w -> GtkM w | gtkWidget w
installSignalHandler handler widget =
- modify (\st ->
+ modState (\st ->
{ st
& signal_handlers = 'Data.Map'.put (st.signal_counter+1) handler_internal st.signal_handlers
, signal_counter = st.signal_counter+1
}) >>|
- gets (\st -> st.signal_counter) >>= \id ->
+ getState >>= \{signal_counter=id} ->
(toState case handler_internal of
GSHI_Void _ -> g_signal_connect_void (toPtr (gtkWidget widget)) signal_name id) >>|
pure widget
diff --git a/src/Gtk/State.dcl b/src/Gtk/State.dcl
index e97f3d3..2a5396c 100644
--- a/src/Gtk/State.dcl
+++ b/src/Gtk/State.dcl
@@ -2,11 +2,9 @@ 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 Control.Applicative import class pure, class <*>, class Applicative
+from Control.Monad import class Monad
+from Data.Functor import class Functor
from Data.Map import :: Map
from Gtk.Signal import :: GSignalHandlerInternal
@@ -18,12 +16,22 @@ from Gtk.Signal import :: GSignalHandlerInternal
, signal_counter :: !Int
}
-:: GtkM a :== State GtkState a
+:: GtkM a =: GtkM (GtkState -> (a, GtkState))
+
+instance Functor GtkM
+instance pure GtkM
+instance <*> GtkM
+instance Monad GtkM
+where
+ (>>|) infixl 1 :: (GtkM a) (GtkM b) -> GtkM b
newGtkState :: GtkState
runGtk :: !(GtkM a) !*World -> (!a, !*World)
+getState :: GtkM GtkState
+modState :: !(GtkState -> GtkState) -> GtkM GtkState
+
toState :: !(A.a: a -> a) -> GtkM ()
toStateR :: !(A.a: a -> (r,a)) -> GtkM r
diff --git a/src/Gtk/State.icl b/src/Gtk/State.icl
index ff97b40..f6e56fe 100644
--- a/src/Gtk/State.icl
+++ b/src/Gtk/State.icl
@@ -3,11 +3,11 @@ implementation module Gtk.State
import StdEnv
import Control.Monad
-import Control.Monad.Identity
-import Control.Monad.State
+import Data.Bifunctor
import qualified Data.Map
from Data.Map import :: Map
import Data.Maybe
+import Data.Tuple
import Gtk.Internal
import Gtk.Signal
@@ -20,45 +20,84 @@ newGtkState =
, signal_counter = 0
}
+instance Functor GtkM where fmap f (GtkM m) = GtkM (first f o m)
+
+instance pure GtkM where pure x = GtkM (tuple x)
+
+instance <*> GtkM
+where
+ <*> (GtkM f) (GtkM x) = GtkM \st
+ # (f,st) = f st
+ # (x,st) = x st
+ -> (f x, st)
+
+instance Monad GtkM
+where
+ bind (GtkM x) k = GtkM (left right)
+ where
+ // NB: we need these two helper functions to hide the tuple type. If
+ // not, tuple-(un)wrapping happens here already causing a stack
+ // overflow. These helpers obscure the types to change the calling
+ // convention, so that an endless bind chain can be executed in
+ // constant space.
+ left right s
+ # (x,s) = x s
+ # k = right x
+ = k s
+ right x
+ # (GtkM k) = k x
+ = k
+
+ (>>|) infixl 1 :: (GtkM a) (GtkM b) -> GtkM b
+ (>>|) (GtkM a) (GtkM b) = GtkM \st -> case a st of (_,st) -> b st
+
runGtk :: !(GtkM a) !*World -> (!a, !*World)
-runGtk f w = (evalState wrapped_f newGtkState, w)
+runGtk f w = (getResult (wrapped_f newGtkState), w)
where
- wrapped_f =
- toState gtk_init >>|
- f >>= \x ->
- main >>|
- pure x
+ (GtkM wrapped_f) = toState gtk_init >>| f >>= \x -> main >>| pure x
+
+ getResult :: !(!a, !GtkState) -> a
+ getResult (r,_) = r
+
main =
toStateR gtk_main_iteration >>|
handle_signals >>|
- gets (\st -> st.return) >>= \return
+ getState >>= \{return}
| return -> pure ()
| otherwise -> main
+
handle_signals =
toStateR g_signal_pop >>= \sig_args -> case sig_args of
Nothing ->
pure ()
Just sig_args ->
- gets (\st -> 'Data.Map'.get sig_args.sig_id st.signal_handlers) >>= \(Just handler) ->
+ getState >>= \{signal_handlers} ->
+ let (Just handler) = 'Data.Map'.get sig_args.sig_id signal_handlers in
run handler >>|
handle_signals
with
run handler = case handler of
- GSHI_Void st -> st >>| handle_signals
+ GSHI_Void st -> st
+
+getState :: GtkM GtkState
+getState = GtkM \st -> (st,st)
+
+modState :: !(GtkState -> GtkState) -> GtkM GtkState
+modState f = GtkM \st -> let st` = f st in (st`,st`)
toState :: !(A.a: a -> a) -> GtkM ()
-toState f = state \st -> let w = f st.world in ((), {st & world=w})
+toState f = GtkM \st -> case f st.world of w=:() -> (w, st)
toStateR :: !(A.a: a -> (r,a)) -> GtkM r
-toStateR f = state \st -> let (r,w) = f st.world in (r, {st & world=w})
+toStateR f = GtkM \st -> case f st.world of (r,()) -> (r, st)
appWorld :: !(*World -> *World) -> GtkM ()
-appWorld f = state \st
+appWorld f = GtkM \st
# w = f (voidToWorld st.world)
-> ((), {st & world=worldToVoid w})
accWorld :: !(*World -> (r,*World)) -> GtkM r
-accWorld f = state \st
+accWorld f = GtkM \st
# (r,w) = f (voidToWorld st.world)
-> (r, {st & world=worldToVoid w})
@@ -72,4 +111,4 @@ worldToVoid :: !*World -> ()
worldToVoid _ = ()
quit :: GtkM ()
-quit = modify \st -> {st & return=True}
+quit = modState (\st -> {st & return=True}) >>| pure ()
diff --git a/src/Gtk/Tune.dcl b/src/Gtk/Tune.dcl
index b970659..61014a8 100644
--- a/src/Gtk/Tune.dcl
+++ b/src/Gtk/Tune.dcl
@@ -1,6 +1,6 @@
definition module Gtk.Tune
-from Gtk.State import :: StateT, :: Identity, :: State, :: GtkState, :: GtkM
+from Gtk.State import :: GtkM
from Gtk.Types import :: GtkCSSClass, :: GtkMargins
from Gtk.Widgets import :: GtkWidget, class gtkWidget
diff --git a/src/Gtk/Tune.icl b/src/Gtk/Tune.icl
index a6d9b0e..d04d691 100644
--- a/src/Gtk/Tune.icl
+++ b/src/Gtk/Tune.icl
@@ -4,8 +4,6 @@ import StdEnv
import Control.Applicative
import Control.Monad
-import Control.Monad.Identity
-import Control.Monad.State
import Gtk
diff --git a/src/Gtk/Widgets.dcl b/src/Gtk/Widgets.dcl
index b027511..b6d6619 100644
--- a/src/Gtk/Widgets.dcl
+++ b/src/Gtk/Widgets.dcl
@@ -5,7 +5,7 @@ from StdMaybe import :: Maybe
from System.FilePath import :: FilePath
from System._Pointer import :: Pointer
-from Gtk.State import :: State, :: StateT, :: Identity, :: GtkState, :: GtkM
+from Gtk.State import :: GtkM
from Gtk.Types import :: GtkCSSClass, :: GtkDirection, :: GtkExpand,
:: GtkFileChooserAction, :: GtkLabel, :: GtkMargins, :: GtkOrientation,
:: GtkPanedHandleWidth, :: GtkResize, :: GtkResponse, :: GtkShrink,
diff --git a/src/Gtk/Widgets.icl b/src/Gtk/Widgets.icl
index 5bf9e10..a2f0d00 100644
--- a/src/Gtk/Widgets.icl
+++ b/src/Gtk/Widgets.icl
@@ -4,8 +4,6 @@ import StdEnv
import StdMaybe
import Control.Monad
-import Control.Monad.Identity
-import Control.Monad.State
import Data.Functor
import Data.Tuple
import System.FilePath
diff --git a/src/Gtk/Widgets/Sheet.dcl b/src/Gtk/Widgets/Sheet.dcl
index 88197ef..9bec404 100644
--- a/src/Gtk/Widgets/Sheet.dcl
+++ b/src/Gtk/Widgets/Sheet.dcl
@@ -1,6 +1,12 @@
definition module Gtk.Widgets.Sheet
-from Gtk.State import :: State, :: StateT, :: Identity, :: GtkState, :: GtkM
+/**
+ * This module provides support for GtkSheet; a spreadsheet widget. See
+ * https://fpaquet.github.io/gtksheet/ for more details and installation
+ * instructions. Use the 'Gtk with GtkSheet' environment.
+ */
+
+from Gtk.State import :: GtkM
from Gtk.Tune import class tune
from Gtk.Widgets import
class gtkWidget, :: GtkWidget,
diff --git a/src/Gtk/Widgets/Sheet.icl b/src/Gtk/Widgets/Sheet.icl
index 442f67d..f27d964 100644
--- a/src/Gtk/Widgets/Sheet.icl
+++ b/src/Gtk/Widgets/Sheet.icl
@@ -1,14 +1,8 @@
implementation module Gtk.Widgets.Sheet
-/**
- * This module provides support for GtkSheet; a spreadsheet widget. See
- * https://fpaquet.github.io/gtksheet/ for more details and installation
- * instructions. Use the 'Gtk with GtkSheet' environment.
- */
+import StdEnv
import Control.Monad
-import Control.Monad.Identity
-import Control.Monad.State
import System._Pointer
import Gtk
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-01 12:06:23 +0000