Definition of the GUI monad.

\begin{code}
module GUIDef where
import WidgetExports (Config,GUIInfo,WindowPrim,CanvasPrim)
import MutSet
import IOExts
import Weak
import FranCore
import WH
import IO
import Identify

newtype GUI a = GUI (GUIDef -> IO (GUIDef,a))

instance Monad GUI where
 return a = GUI $ \info -> return (info,a)
 (GUI a) >>= f = GUI $ \info ->  do
		  (info,v) <- a info
		  case f v of 
                    GUI a -> a info
 fail err = failGUI (userError err)

instance Functor GUI where
 fmap f a = do
	v <- a
	return $ f v


failGUI :: IOError -> GUI a
failGUI err = GUI (\_ -> ioError err)
		   

tryGUI :: GUI a -> GUI (Either IOError a)
tryGUI (GUI f) = GUI (\st -> do res <- try (f st)
			        case res of
				   Left err -> return (st,Left err)
				   Right (i,v) -> return (i,Right v))

catchGUI :: GUI a -> (IOError -> GUI a) -> GUI a
catchGUI (GUI gui) hdl = GUI gui'
      where
	gui' st = catch (gui st) (hdl' st)

	hdl' st err = case hdl err of
		        GUI hdl_gui -> hdl_gui st
\end{code}

The gui monad contains GUIInfo, which is explicit state for the underlying
widget system (handled abstractly), a unique name supply, a mutable set of
remove actions for active widgets (see PrimWidget below for why),
the current window, the root window, the since variable and perhaps a 
current canvas if we're in one.

The since variable is used in GUI.lhs.
\begin{code}

data GUIDef = GUIDef {
	guiInfo :: GUIInfo,
	nameSupply :: ! (IORef Int),
	activeWidgets :: ! (MutSet RemRef),
	currentWindow :: Window,
	rootWindowRef :: Window,
	since :: IORef Double,
	currentCanvas :: (Maybe Canvas),
	currentStyle :: Conf Style
	}

mkGUIDef :: GUIInfo -> Window -> IO GUIDef
mkGUIDef gui win = do 
 ref <- newIORef 0
 mset <- newMutSet
 tm <- newIORef 0
 return $! GUIDef gui ref mset win win tm Nothing emptyConf

\end{code}


The type Config is widget system (such as TclHaskell) dependent and is 
imported abstractly. All other configuration options are functions from
the widget to a GUI action.

\begin{code}

emptyConf :: Conf w
emptyConf = Conf []

newtype Conf w = Conf [ConfItem w]

instance Show (Conf w) where
 show c = "Conf"

data ConfItem w = Config Config | ConfGUI ConfigName (w -> GUI ())

type ConfigName = Ident

instance Identifiable (ConfItem w) where
 identify (Config c) = identify c
 identify (ConfGUI c _) = c
 identify _ = nullId

instance Eq (ConfItem w) where
 c1 == c2 = let i1 = identify c1 
                i2 = identify c2 
            in i1 == i2 && i1 /= nullId && i2 /= nullId

\end{code}

Style is a generic configuration type for global options in scope, 
such as background color 

\begin{code}

data Style = forall w . (WidgetItem w) => Style w 

instance WidgetItem Style where
  cset (Style w) cs = cset w cs
  destroy (Style w) = destroy w
  uniqueId (Style w) = uniqueId w
  addFinaliserW (Style w) act = addFinaliserW w act

\end{code}

A window and canvas are imported from the underlying toolkit, but
are wrapped in a PrimWidget. 
See PrimWidget.lhs for more on prim widgets (we really need mutually
recursive modules here).

\begin{code}
type RemRef = IORef (Maybe Remover)

type Window = PrimWidget WindowPrim
type Canvas = PrimWidget CanvasPrim

data PrimWidget w = PrimWidget {
	addingRef :: IORef Int,
	guiDef :: ! GUIDef,
	widgetPrim :: ! w,
	hideRef :: ! RemRef,
	hideRefWP :: ! (Weak RemRef),
	actionPE :: Event ()
	}
\end{code}

Some GUI funtions to access GUIDef.

\begin{code}
getUniqueName :: GUI Int
getUniqueName = withGUIDef $ \(GUIDef {nameSupply = ref}) -> do
 v <- readIORef ref
 writeIORef ref (v+1)
 return $! v


liftIO :: IO a -> GUI a
liftIO io = GUI $ \info -> do v <- io;return (info,v)

getGUIDef :: GUI GUIDef
getGUIDef = GUI $ \info -> return (info,info)

updGUIDef :: (GUIDef -> GUIDef) -> GUI ()
updGUIDef f = GUI $ \info -> return (f info,())

runGUI :: GUIDef -> GUI a -> IO a
runGUI gd (GUI f) = fmap snd $ f gd

fromGUI :: GUI a -> GUI (IO a)
fromGUI (GUI a) = GUI $ \info -> return (info,fmap snd $ a info)

withGUIInfo :: (GUIInfo -> IO a) -> GUI a
withGUIInfo f = GUI $ \i -> do v <- f (guiInfo i);return (i,v)


withGUIDef :: (GUIDef -> IO a) -> GUI a
withGUIDef f = GUI $ \i -> do v <- f i;return (i,v)

setGUIInfo :: GUIInfo -> GUI ()
setGUIInfo gi = updGUIDef (\g -> g {guiInfo = gi})

setCurrentWindow :: Window -> GUI ()
setCurrentWindow win = updGUIDef (\g -> g {currentWindow = win})

getCurrentWindow :: GUI Window
getCurrentWindow = fmap currentWindow $ getGUIDef

getRootWindow :: GUI Window
getRootWindow = fmap rootWindowRef $ getGUIDef

setInCanvas :: Canvas -> GUI ()
clearFromCanvas :: GUI ()

setInCanvas c = updGUIDef (\g -> g {currentCanvas = Just c})
clearFromCanvas = updGUIDef (\g -> g {currentCanvas = Nothing})


addGUIB :: Behavior (GUI ()) -> GUI (GUI ())
addGUIB bh = do 
 info <- getGUIDef
 rm <- liftIO $ addIOB $ lift1 (runGUI info) bh
 return $ liftIO rm

\end{code}