{-# OPTIONS_GHC -fasm -fglasgow-exts #-}

module ZMachine.IO.Gtk (startUI) where

import ZMachine.IO.Base
import Data.Word

import Control.Monad.State hiding (get)
import qualified Control.Monad.State as CMS
import Control.Concurrent

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Multiline.TextView
import Graphics.UI.Gtk.Abstract.Widget

data UIState = UIS { uisWindow :: Word16 }

startUI :: IO (ThreadId, Chan IOOperation)
startUI = do chan <- newChan
             tid <- forkIO $ runUI chan
             return (tid, chan)

runUI :: Chan IOOperation -> IO ()
runUI chan = do initGUI
                win <- windowNew
                windowSetDefaultSize win 495 475
                vbox <- vBoxNew False 4
                containerAdd win vbox

                scroll <- scrolledWindowNew Nothing Nothing
                set scroll [ widgetCanFocus := False ]
                containerAdd vbox scroll

                textView <- textViewNew
                containerAdd scroll textView

                buffer   <- textViewGetBuffer textView

                set textView [ textViewEditable := False,
                               textViewWrapMode := WrapWord,
                               textViewCursorVisible := False,
                               widgetCanFocus := False ]

                entry <- entryNew
                widgetGrabFocus entry

                boxPackStart vbox entry PackNatural 0

                entryMVar <- newEmptyMVar
                onEntryActivate entry
                    (do s <- get entry entryText
                        insertAtEndAndScroll buffer textView (s ++ "\n")
                        putMVar entryMVar s
                        set entry [entryText := ""])

                widgetShowAll win
                timeoutAddFull (yield >> return True) priorityDefaultIdle 50

                let

                forkIO (evalStateT (loop textView buffer entry entryMVar)
                                   (UIS 0))
                mainGUI
                return ()

    where
    loop view buffer entry entryMVar = forever $
        do op <- liftIO $ readChan chan
           win <- gets uisWindow
           case op of
            IOWrite s
               | win == 1 -> return ()
               | otherwise
                   -> liftIO $ insertAtEndAndScroll buffer view s
            IORead mv -> liftIO $ takeMVar entryMVar >>= putMVar mv
            IOReadChar mv
                -> liftIO $
                   mdo con <- onKeyPress entry
                              (\ev -> do signalDisconnect con
                                         case eventKeyChar ev of
                                          Just char
                                             -> putMVar mv char
                                          Nothing
                                             -> do liftIO $
                                                    print (eventKeyName ev)
                                                   putMVar mv ' '
                                         return True
                              )
                       return ()

            IOEraseWindow _  -> return ()
            IOSetWindow wind -> modify (\uis -> uis { uisWindow = wind })
            IOSplitWindow _  -> return ()
            IOSetCursor _ _  -> return ()

insertAtEndAndScroll :: (TextViewClass self1, TextBufferClass self) => self -> self1 -> String -> IO ()
insertAtEndAndScroll buffer view text =
    do end <- textBufferGetEndIter buffer
       textBufferPlaceCursor buffer end
       textBufferInsert buffer end text
       textBufferGetInsert buffer >>= textViewScrollMarkOnscreen view