module Hbro.Gui where
import Control.Monad.Trans(liftIO)
import Graphics.UI.Gtk
import Graphics.UI.Gtk.WebKit.WebView
data GUI = GUI {
mWindow :: Window,
mInspectorWindow :: Window,
mWebView :: WebView,
mPromptLabel :: Label,
mPrompt :: Entry,
mWindowBox :: VBox,
mStatusBox :: HBox,
mProgressLabel :: Label,
mUrlLabel :: Label
}
loadGUI :: String -> IO GUI
loadGUI gladePath = do
window <- windowNew
inspectorWindow <- windowNew
windowSetDefaultSize window 1024 768
windowSetPosition window WinPosCenter
set window [ windowTitle := "hbro" ]
webView <- webViewNew
winBox <- vBoxNew False 0
promptBox <- hBoxNew False 10
statusBox <- hBoxNew False 5
scrollWin <- scrolledWindowNew Nothing Nothing
promptLabel <- labelNew Nothing
promptEntry <- entryNew
progressLabel <- labelNew (Just "0%")
urlLabel <- labelNew (Just "")
boxPackStart winBox scrollWin PackGrow 0
boxPackStart winBox promptBox PackNatural 0
boxPackStart winBox statusBox PackNatural 0
boxPackStart promptBox promptLabel PackNatural 0
boxPackStart promptBox promptEntry PackGrow 0
boxPackStart statusBox progressLabel PackNatural 0
boxPackStart statusBox urlLabel PackNatural 0
window `containerAdd` winBox
scrollWin `containerAdd` webView
set webView [ widgetCanDefault := True ]
windowSetDefault window (Just webView)
_ <- on webView closeWebView $ do
mainQuit
return True
return $ GUI window inspectorWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel
showPrompt :: Bool -> GUI -> IO ()
showPrompt toShow gui = case toShow of
False -> do widgetHide (mPromptLabel gui)
widgetHide (mPrompt gui)
_ -> do widgetShow (mPromptLabel gui)
widgetShow (mPrompt gui)
prompt :: String -> String -> Bool -> GUI -> (GUI -> IO ()) -> IO ()
prompt label defaultText incremental gui callback = do
showPrompt True gui
labelSetText (mPromptLabel gui) label
entrySetText (mPrompt gui) defaultText
widgetGrabFocus (mPrompt gui)
case incremental of
True -> do
id1 <- on (mPrompt gui) editableChanged $
liftIO $ callback gui
rec id2 <- on (mPrompt gui) keyPressEvent $ do
key <- eventKeyName
case key of
"Return" -> do
liftIO $ showPrompt False gui
liftIO $ signalDisconnect id1
liftIO $ signalDisconnect id2
liftIO $ widgetGrabFocus (mWebView gui)
"Escape" -> do
liftIO $ showPrompt False gui
liftIO $ signalDisconnect id1
liftIO $ signalDisconnect id2
liftIO $ widgetGrabFocus (mWebView gui)
_ -> return ()
return False
return ()
_ -> do
rec id <- on (mPrompt gui) keyPressEvent $ do
key <- eventKeyName
case key of
"Return" -> do
liftIO $ showPrompt False gui
liftIO $ callback gui
liftIO $ signalDisconnect id
liftIO $ widgetGrabFocus (mWebView gui)
"Escape" -> do
liftIO $ showPrompt False gui
liftIO $ signalDisconnect id
liftIO $ widgetGrabFocus (mWebView gui)
_ -> return ()
return False
return ()