implementation module Gtk.State

import StdEnv

import Control.Monad
import Data.Bifunctor
import Data.Functor
import qualified Data.Map
from Data.Map import :: Map
import Data.Maybe
import Data.Tuple

import Gtk
import Gtk.Internal

newGtkState :: GtkState
newGtkState =
	{ world           = ()
	, return          = False
	, signal_handlers = 'Data.Map'.newMap
	, signal_counter  = 0
	, timeouts        = 'Data.Map'.newMap
	, timeout_counter = 0
	, shares          = 'Data.Map'.newMap
	}

instance Functor GtkM
where
	fmap f (GtkM m) = GtkM \st
		#! (x,st) = m st
		-> (f x,st)

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

runGtk :: !(GtkM a) !*World -> (!a, !*World)
runGtk f w = (getResult (wrapped_f newGtkState), w)
where
	getResult :: !(!a, !GtkState) -> a
	getResult (r,_) = r

	(GtkM wrapped_f) =
		toState gtk_init >>|
		f >>= \x ->
		saveState >>|
		main x

	main x =
		toStateR gtk_main_iteration >>|
		retrieveState >>= \{return}
			| return    -> pure x
			| otherwise -> main x

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 = GtkM \st -> case f st.world of w=:() -> (w, st)

toStateR :: !(A.a: a -> (r,a)) -> GtkM r
toStateR f = GtkM \st -> case f st.world of (r,()) -> (r, st)

appWorld :: !(*World -> *World) -> GtkM ()
appWorld f = GtkM \st
	# w = f (voidToWorld st.world)
	-> ((), {st & world=worldToVoid w})

accWorld :: !(*World -> (r,*World)) -> GtkM r
accWorld f = GtkM \st
	# (r,w) = f (voidToWorld st.world)
	-> (r, {st & world=worldToVoid w})

voidToWorld :: !() -> *World
voidToWorld _ = code {
	fill_a 0 1
	pop_a 1
}

worldToVoid :: !*World -> ()
worldToVoid _ = ()

quit :: GtkM ()
quit = modState (\st -> {st & return=True}) >>| pure ()