1 files changed, 55 insertions, 16 deletions

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 ()