Some more gui monad operations.

\begin{code}

module GUI (module GUI,module GUIDef,GUIInfo) where
import IO
import FranCore
import BVars
import IOExts
import WH
import MutSet
import Identify
import WidgetExports (debugW,runLoop,GUIInfo,rootWinPrim,getWTime,quitW,
		      afterW,everyW,updateW,primRunW,primRunW_)
import GUIDef
import Conf
import Compatibility
import Monad
\end{code}

Run a GUI operation.
This involves creating a GUIDef, and running the toolkit event loop.
We run a closeDown action at the end.
We get the root window and make it the current window, setup fran,
and then run the GUI action. Updating behaviors afterwards

\begin{code}
start :: GUI () -> IO ()
start act = do
 info <- mkGUIDef (error "no GUIInfo yet") (error "no windows yet")
 runLoop (closeDown info) $ \g -> do
  win <- rootWinPrim g
  win <- mkSimplePrim win info 
  franInit
  let info' = info {guiInfo = g,currentWindow = win,rootWindowRef = win}
  primAction info' $ runGUI info' $ act
\end{code}

make a simple prim widget. 

\begin{code}
mkSimplePrim :: w -> GUIDef -> IO (PrimWidget w)
mkSimplePrim w info = do
 aref <- newIORef 0
 ref <- newIORef Nothing
 wp <- mkWeakIORef ref (return ())
 return $ PrimWidget aref info w ref wp neverE
\end{code}

quit - shutdown everything

\begin{code}
quit :: GUI ()
quit = withGUIInfo quitW 
\end{code}

set debugging info for the underlying toolkit

\begin{code}
debug :: Bool -> GUI ()
debug b = withGUIInfo $ debugW b
\end{code}

set timers

\begin{code}
after :: Double -> GUI () -> GUI (IO ())
after v act = withGUIDef $ \g -> do
  afterW v (primAction g (runGUI g act)) (guiInfo g)
\end{code}

close down cleanly by zapping all the fran global variables, and garbage 
collecting then running finalisers. This is important in hugs to stop
weak pointers doing funny stuff.

\begin{code} 
closeDown :: GUIDef -> IO ()
closeDown (GUIDef {nameSupply = nms,activeWidgets = mset}) = do
 franInit
 clearMutSet mset
 writeIORef nms 0
 performGC >> yield
 performGC >> yield
 performGC >> yield
\end{code}

a primitive action ie user input, causes the current time to be set.
the action is then run. the time remains constant in this running step.
we then get the time after the step and run all the fran workpools once.
every 10 seconds we garbage collect and run finalisers, to make sure
we're zapping weak pointers.

\begin{code}
primAction :: GUIDef -> IO () -> IO ()
primAction (GUIDef {guiInfo = gui,since = ref}) act = do
 t <- getWTime gui
 setFranTime t
 act
 t <- getWTime gui
 runFranOnce t
 tr <- readIORef ref
 when (t - 10 > tr) $ do
  writeIORef ref t
  performGC
  yield
\end{code}


Run some primitive code

\begin{code}
primRun :: [String] -> GUI String
primRun_ :: [String] -> GUI ()

primRun = withGUIInfo . primRunW
primRun_ = withGUIInfo . primRunW_

\end{code}

update behaviors and the display
\begin{code}
update :: GUI ()
update = withGUIDef $ \g -> primAction g (return ()) >> updateW (guiInfo g)
\end{code}

IORefs in the GUI monad.
They're here but not directly exported from frantk at the moment.
we'll see if there is any demand. there generally shouldn't be
as BVars should be capable of doing everything.

\begin{code}
type GUIRef a = IORef a

newState :: a -> GUI (GUIRef a)
newState a = liftIO $ newIORef a

readState :: GUIRef a -> GUI a
readState = liftIO . readIORef

writeState :: GUIRef a -> a -> GUI ()
writeState ref f = liftIO $ writeIORef ref f

modState :: GUIRef a -> (a -> a) -> GUI ()
modState ref f = liftIO $ updIORef ref f

type GUIArray a = IOArray Int a

newGUIArray :: Int -> a -> GUI (GUIArray a)
newGUIArray n x = liftIO  (newIOArray (0,n-1) x)

readGUIArray :: GUIArray a -> Int -> GUI a
readGUIArray arr i = liftIO  (readIOArray arr i)

writeGUIArray :: GUIArray a -> Int -> a -> GUI ()
writeGUIArray arr i x = liftIO  (writeIOArray arr i x)

modGUIArray :: GUIArray a -> Int -> (a->a) -> GUI ()
modGUIArray arr i f = do x <- readGUIArray arr i; writeGUIArray arr i (f x)
\end{code}

Update and use Styles

\begin{code}

getStyle :: GUI (Conf Style)
getStyle = do 
 (GUIDef {currentStyle = cs}) <- getGUIDef
 return cs

withStyle' :: [Conf Style] -> GUI a -> GUI a
withStyle' cs act = do
 oldc <- getStyle
 updGUIDef $ \g -> g {currentStyle = composeConfs $ cs ++ [oldc]}
 a <- act
 updGUIDef $ \g -> g {currentStyle = oldc}
 return a

\end{code}


We can define behavioral configuration options in terms of static ones.
Every time the behavior changes we update the config value (we can also
optimise by checking for equality and only updating when the value has
actually changed.)

\begin{code}
csetAllB :: WidgetItem w => [ConfigName] -> w -> [Conf w] -> GUI ()
csetAllB valids w cs =  do
 s <- getStyle
 case getConfigs valids s cs of
  (cs,as) -> do
    liftIO $ cset w $ reverse cs
    as w

csetAllB' :: WidgetItem w => [ConfigName] -> w -> [Conf w] -> Conf Style -> GUI ()
csetAllB' valids w cs s =  do
 case getConfigs valids s cs of
  (cs,as) -> do
    liftIO $ cset w $ reverse cs
    as w


csetB :: WidgetItem w =>  w -> [Conf w] -> GUI ()
csetB w cs =  do
 s <- getStyle
 case getConfigs [] emptyConf cs of
  (cs,as) -> do
    liftIO $ cset w $ reverse cs
    as w

setB' :: (WidgetItem w) => (a -> a -> Bool) 
		        -> w -> (a -> Conf w) -> Behavior a -> GUI ()
setB' eq w c (bh :: Behavior a) = do
 ref <- liftIO $ newIORef (const False)
 let set gui v = do
	f <- readIORef ref
        unless (f v) $ do
	  writeIORef ref (eq v)
	  runGUI gui $ csetB w [c v]
 gui <- getGUIDef 
 rm <- liftIO $ addIOB (lift1 (set gui) bh)
 liftIO $ addFinaliserW w rm
 return ()
          
setB :: (WidgetItem w,Eq a) =>  w -> (a -> Conf w) -> Behavior a -> GUI ()
setB = setB' (==)

confBeh :: (WidgetItem w,Eq a) => ConfigName -> (a -> Conf w) -> Behavior a -> Conf w
confBeh nm f bh = confGUI' nm $ \w -> setB w f bh

actB :: WidgetItem w => (w -> a -> IO ()) -> Behavior a -> w -> IO ()
actB f b w = do
 rm <- addIOB (lift1 (f w) b) 
 addFinaliserW w rm
 return ()
\end{code}