hbro-0.2: src/Gui.hs

{-# LANGUAGE DoRec #-}
module Gui where

-- {{{ Imports
import Control.Monad.Trans(liftIO)

import Graphics.UI.Gtk
import Graphics.UI.Gtk.WebKit.WebView
-- }}}

data GUI = GUI {
    mWindow             :: Window,  -- ^ Main window
    mInspectorWindow    :: Window,  -- ^ WebInspector window
    mWebView            :: WebView, -- ^ Browser's webview
    mPromptLabel        :: Label,   -- ^ Description of current prompt
    mPrompt             :: Entry,   -- ^ Prompt entry
    mWindowBox          :: VBox,    -- ^ Window's layout
    mStatusBox          :: HBox,    -- ^ Status bar's layout
    mProgressLabel      :: Label,
    mUrlLabel           :: Label
}

-- {{{ Load glade GUI
-- | Load GUI from a glade file.
loadGUI :: String -> IO GUI
loadGUI gladePath = do
--        -- Note: crashes with a runtime error on console if fails!
--        Just xml <- xmlNew gladePath

--        -- Load main window
--        -- castTo* don't exist :(
--        window       <- xmlGetWidget xml castToWindow    "window"
--        webView      <- xmlGetWidget xml castToWebView   "webView"
--        promptLabel  <- xmlGetWidget xml castToLabel     "promptLabel"
--        prompt       <- xmlGetWidget xml castToEntry     "prompt"

    window          <- windowNew
    inspectorWindow <- windowNew

    windowSetDefaultSize window 1024 768
    windowSetPosition window WinPosCenter
    --windowSetOpacity window 0.8 
    --windowSetIconFromFile window "/path/to/icon"
    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

    _ <- on webView closeWebView $ do
        mainQuit
        return True

    --webFrame <- webViewGetMainFrame webView

    return $ GUI window inspectorWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel
-- }}}

-- | Show or hide the prompt bar (label + entry).
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)

-- | Show the prompt bar label and default text.
-- As the user validates its entry, the given callback is executed.
prompt :: String -> String -> GUI -> (GUI -> IO ()) -> IO ()
prompt label defaultText gui callback = do
    -- Show prompt
    showPrompt True gui

    -- Fill prompt
    labelSetText (mPromptLabel gui) label
    entrySetText (mPrompt gui) defaultText

    widgetGrabFocus (mPrompt gui)

    -- Register callback
    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 ()


-- promptFind :: Maybe String -> GUI -> IO ()
-- promptFind label gui = do
--     -- Show prompt
--     widgetShow (mPromptLabel gui)
--     widgetShow (mPrompt gui)

--     -- Fill prompt
--     case label of
--         Just text -> labelSetText (mPromptLabel gui) text
--         _         -> return ()

--     widgetGrabFocus (mPrompt gui)

--     -- Register callback
--     rec id <- on (mPrompt gui) keyPressEvent $ do
--         key         <- eventKeyName
--         --keywords    <- entryGetText (mPrompt gui)

--         case key of
--             "Return" -> do liftIO $ widgetHide (mPromptLabel gui)
--                            liftIO $ widgetHide (mPrompt gui)
--                            liftIO $ webViewMarkTextMatches (mWebView gui) keywords True 0
--                            liftIO $ signalDisconnect id
--             "Escape" -> do liftIO $ widgetHide (mPromptLabel gui)
--                            liftIO $ widgetHide (mPrompt gui)
--                            liftIO $ signalDisconnect id
--             _        -> return ()

--         return False

--     return ()
--