module TclGUI (module TclGUI,Remover,parseInt)where
import Remover
import Char
import IO
import System
import TclCompatibility
import Monad
import TclTrie
import IOExts
import ExtArray
import Int
import TclTime

type TclGUI a = GUIInfo -> IO a

-- Lifted Communication Primitives ---------------------

tcl_debug :: Bool -> TclGUI ()
tcl_debug flg _ = primTclDebug flg

tcl_initTcl :: GUIInfo -> IO ()
tcl_initTcl gui =
     do ok <- primInitTcl
	if ok
	   then tcl_ gui [init_script]
 	   else error "initialization error"
 
tcl :: GUIInfo -> [String] -> IO String
tcl _ ss = primExecuteTcl (unwords ss)
 
tcl_ :: GUIInfo -> [String] -> IO ()
tcl_ _ ss = primExecuteTcl_ (unwords ss)

runTcl :: GUIInfo -> IO Bool
runTcl _ = primRunTcl 

getEvent :: GUIInfo -> IO String
getEvent _ = primGetEvent

-- the GUI State ----------------------------------------
 
data GUIInfo = GUIInfo {
	finaliseGUI :: IORef (IO ()),
	namesfromGUI :: IORef Int,
	callbacksGUI :: TkCB,
	tclTrie :: TclTrie,
	tclTime :: IORef Int
	}

type TkCB = ExtArray TkCBEntry
newtype TkCBEntry = TkCBEntry ([String]-> IO ())


-- Making a GUI State ----------------------------------

tcl_initState :: IO GUIInfo
tcl_initState =
     do qtp <- newIORef (return ())
	ctr <- tcl_initPathNames
	cb  <- tcl_initCallbacks
	trie <- mkTclTrie
	tm <- newIORef 0 
        return $! GUIInfo qtp ctr cb trie tm

-- Using the TclTrie ------------------------------------

register :: GUIInfo -> String -> IO TrieObjV
register (GUIInfo {tclTrie = trie}) = register_ trie

lookupTrieObj :: GUIInfo -> String -> IO (Maybe TrieObjV)
lookupTrieObj (GUIInfo {tclTrie = trie}) = lookupTrieObj' trie 

widgetAlive' :: GUIInfo -> String -> IO Bool
widgetAlive' (GUIInfo {tclTrie = trie}) = checkAlive_ trie

addFinaliserW' :: GUIInfo -> String -> Remover -> IO ()
addFinaliserW' (GUIInfo {tclTrie = trie}) = addFinaliserW_ trie

runDeletes :: GUIInfo -> String -> IO Bool
runDeletes (GUIInfo {tclTrie = trie}) = doDelete trie

-- Inventing New Names ----------------------------------

tcl_initPathNames :: IO (IORef Int)

tcl_initPathNames = newIORef 0

tcl_newWgtName :: GUIInfo -> IO String
tcl_newWgtName info = 
     do n <- tcl_newName info
	return ('.':'@':(show n))

tcl_newName :: GUIInfo -> IO Int
tcl_newName (GUIInfo {namesfromGUI = ctr}) = 
     do n <- readIORef ctr
	writeIORef ctr (n+1)
	return n

-- The Callback Structure -------------------------------

tcl_initCallbacks :: IO TkCB
tcl_initCallbacks = newExtArray 1000

tcl_addCallback :: GUIInfo -> TkCBEntry -> IO Int
tcl_addCallback (GUIInfo {callbacksGUI = cb}) p = do
  nm <- nextExtEntry cb 
  writeExtArray cb nm p
  return nm

tcl_removeCallback :: GUIInfo -> Int -> IO ()
tcl_removeCallback (GUIInfo {callbacksGUI = cb}) n = do
  clearExtArray cb n

tcl_getAct :: GUIInfo -> [String] -> IO (IO ())
tcl_getAct _ [] = return (return ())
tcl_getAct (GUIInfo {callbacksGUI = cb}) (num:args) = do
 mbp <- readExtArray cb (parseInt num)
 case mbp of
  Nothing -> return (return ())
  Just (TkCBEntry act) -> return (act args)

-- Callbacks -------------------------------------------

tcl_callback :: GUIInfo -> String -> ([String]-> IO ()) 
	     -> IO (String,Remover)
tcl_callback gui args a =
     do nr <- tcl_addCallback gui (TkCBEntry a )
	rm <- mkRemover $ tcl_removeCallback gui nr
	return (tcl_cb nr,rm)
      where
	tcl_cb nr = unwords (["{haskellEvent \"", show nr] ++ 
					[['%',c] | c<-args] ++ ["\"}"])

-- Quitting --------------------------------------------

quit :: GUIInfo -> IO ()
quit gui@(GUIInfo {finaliseGUI = rf,tclTrie = trie}) = do
	alv <- checkAlive_ trie "."
	when alv $ do
 	 p <- readIORef rf
	 p
	 doDelete trie "." 
	 tcl_ gui ["destroy ."]

tcl_tidy :: GUIInfo -> IO () -> IO ()
tcl_tidy gui@(GUIInfo {finaliseGUI = rf}) p = do
	writeIORef rf p

-- The Event Loop --------------------------------------

tcl_init :: GUIInfo -> IO () -> IO ()
tcl_init gui initact =
  do tcl_initTcl gui  -- init tcl/tk
     initact          -- perform first action
     tcl_cycle gui


tcl_cycle :: GUIInfo -> IO ()
tcl_cycle gui =
     do	fin <- runTcl gui                  -- run Tcl's event loop in
	case fin of			   -- one-shot mode
	  True  -> tcl_event gui	   -- True  => process events
	  False -> return ()               -- False => `.' destroyed

tcl_event :: GUIInfo -> IO ()
tcl_event gui =
     do s <- getEvent gui                  -- read event buffer
	case s of
	  "" -> tcl_cycle gui              -- all events processed:
					   --        cycle to next event
	  _  ->
	     do	a <- tcl_getAct gui (words s)  -- get action
		catch a tidy               -- execute action
		tcl_event gui              -- process next event
      where
	tidy err = do quit gui; ioError err

tcl_eventUntil :: GUIInfo -> IO Bool -> IO ()
tcl_eventUntil gui st =
   do fin <- primRunTcl
      when fin event
      v <- st
      if v || not fin
         then return ()
         else tcl_eventUntil gui st
  where
   event = do s <- primGetEvent
              a <- tcl_getAct gui (words s)
              catch a tidy
           where
              tidy err = do quit gui; ioError err

-- Clearing the Event Queue ----------------------------

tcl_clearEventQueue :: GUIInfo -> IO ()
tcl_clearEventQueue gui =
     do s <- primGetEvent
	case s of
	  "" -> return ()
	  _  -> tcl_clearEventQueue gui


runLoop :: (GUIInfo -> IO ()) -> IO ()
runLoop initact = do
        st <- tcl_initState
        tcl_init st $ do
          (tcl_cb,_) <- tcl_callback st  "" (\_->quit st) 
	  tcl_ st ["wm protocol . WM_DELETE_WINDOW", tcl_cb]
	  ms <- getTclTime 
	  writeIORef (tclTime st) ms
	  initact st

getTime :: GUIInfo -> IO Double
getTime gui@(GUIInfo {tclTime = var}) = do
  ms <- getTclTime 
  startMS <- readIORef var
  return $ abs (fromIntegral (ms - startMS) / 1000)

-- init_script -------------------------------------------
 
init_script :: String
init_script = unlines

	----------------------------------------------------
	-- The Tk Popup menus seem to be banjaxed in some
	-- versions...
	----------------------------------------------------
	 
	["proc haskell_popup {menu x y {entry {}}} {"
	,"    global tkPriv"
	,"    global tcl_platform"
	,"    if {($tkPriv(popup) != \"\") || ($tkPriv(postedMb) != \"\")} {"
	,"       tkmenuunpost {}"
	,"    }"
	,"    tkPostOverPoint $menu $x $y $entry"
	,"    if {$tcl_platform(platform) == \"unix\"} {"
	,"      tkSaveGrabInfo $menu"
	,"      grab -global $menu"
	,"      set tkPriv(popup) $menu"
	,"      tk_menuSetFocus $menu"
	,"    }"
	,"}"

	----------------------------------------------------
	-- haskellLoadFile : load file into text widget,
	-- 1000 bytes at a time
	----------------------------------------------------
	
	,"proc haskellInsertFile {file text posn tags} {"
	,"    set f [open $file r]"
	,"    $text mark set haskellInsertFile $posn"
	,"    while {![eof $f]} {"
	,"      $text insert haskellInsertFile [read $f 1000] $tags"
	,"    }"
	,"    $text mark unset haskellInsertFile"
	,"    close $f"
	,"}"
	
	----------------------------------------------------
	-- haskellSaveFile : save file from text widget,
	-- 20 lines at a time
	----------------------------------------------------
	
	,"proc haskellSaveFile {file text} {"
	,"    set f [open $file w]"
	,"    scan [$text index end] \"%d.\" x"
	,"    for {set i 1} {$i < $x-20} {incr i 20} {"
	,"      puts $f [$text get $i.0 [expr $i+19].end]"
	,"    }"
	,"    puts -nonewline $f [$text get $i.0 end]"
	,"    close $f"
	,"}"
	]