Add custom GtkM state monad with a bind that does not grow the stack

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