hbro-1.0.0.0: Hbro/Gui.hs

{-# LANGUAGE DoRec, FlexibleContexts, FlexibleInstances #-}
module Hbro.Gui where

-- {{{ Imports
--import Hbro.Core
import Hbro.Util
import qualified Hbro.Prompt as Prompt
import Hbro.Types
import Hbro.Webkit.WebView

import Control.Conditional
import Control.Monad hiding(forM_, mapM_)
import Control.Monad.IO.Class
import Control.Monad.Reader

--import Data.Foldable
import Data.Functor

import Graphics.Rendering.Pango.Enums
import Graphics.UI.Gtk.Abstract.Container
import Graphics.UI.Gtk.Abstract.Box
import Graphics.UI.Gtk.Abstract.Widget
import Graphics.UI.Gtk.Builder
import Graphics.UI.Gtk.Display.Label
import qualified Graphics.UI.Gtk.General.General as GTK
import Graphics.UI.Gtk.Layout.HBox
import Graphics.UI.Gtk.Layout.VBox
import Graphics.UI.Gtk.Scrolling.ScrolledWindow
import Graphics.UI.Gtk.WebKit.WebInspector
import Graphics.UI.Gtk.WebKit.WebView hiding(webViewLoadUri)
import Graphics.UI.Gtk.Windows.Window

import Prelude hiding(mapM_)

import System.Glib.Attributes
import System.Glib.Signals
import System.Glib.Types
-- }}}

-- Util
-- | Return the casted GObject corresponding to the given name (set in the builder's XML file)
getObject :: (MonadIO m, MonadReader r m, HasGUI r, GObjectClass a) => (GObject -> a) -> String -> m a
getObject cast name = do
    builder <- asks _builder
    io $ builderGetObject builder cast name

build' :: (MonadIO m, MonadReader r m, HasConfig r) => m GUI
build' = do
    xmlPath <- asks _UIFile
    io $ void GTK.initGUI
-- Load XML
    xmlPath' <- io xmlPath
    logNormal $ "Loading GUI from " ++ xmlPath' ++ "... "
    builder <- io builderNew
    io $ builderAddFromFile builder xmlPath'
-- Build components
    (webView, sWindow) <- build builder
    (window, wBox)     <- build builder
    promptBar          <- build builder
    statusBar          <- build builder
    notificationBar    <- build builder
    inspectorWindow    <- initWebInspector webView wBox
-- Show window
    io $ widgetShowAll window
    io $ widgetHide (_box promptBar)

    logNormal "Done."
    return $ GUI {
        __mainWindow      = window,
        __inspectorWindow = inspectorWindow,
        __scrollWindow    = sWindow,
        __webView         = webView,
        __promptBar       = promptBar,
        __statusBar       = statusBar,
        __notificationBar = notificationBar,
        __builder         = builder
    }

setupScrollWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m ()
setupScrollWindow = do
    window <- asks _scrollWindow
    io $ scrolledWindowSetPolicy window PolicyNever PolicyNever

instance Buildable (Window, VBox) where
    build builder = io $ do
        window <- builderGetObject builder castToWindow "mainWindow"
        box    <- builderGetObject builder castToVBox "windowBox"
        return (window, box)

setupWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m ()
setupWindow = do
    window <- asks _mainWindow
    io . windowSetDefault window . Just =<< asks _webView
    io $ windowSetDefaultSize window 800 600
    io $ widgetModifyBg window StateNormal (Color 0 0 10000)
    io . void $ onDestroy window GTK.mainQuit

instance Buildable StatusBar where
    build builder = io $ StatusBar <$> builderGetObject builder castToHBox "statusBox"

instance Buildable NotificationBar where
    build builder = io $ NotificationBar <$> builderGetObject builder castToLabel "notificationLabel"

-- {{{ Web inspector
initWebInspector :: (MonadIO m) => WebView -> VBox -> m (Window)
initWebInspector webView windowBox = do 
    inspector       <- io $ webViewGetInspector webView
    inspectorWindow <- io windowNew
    io $ set inspectorWindow [ windowTitle := "hbro | Web inspector" ]

    _ <- io $ on inspector inspectWebView $ \_ -> do
        view <- webViewNew
        containerAdd inspectorWindow view
        return view
    
    _ <- io $ on inspector showWindow $ do
        widgetShowAll inspectorWindow
        return True

-- TODO: when does this signal happen ?!
    --_ <- on inspector finished $ return ()

-- Attach inspector to browser's main window
    _ <- io $ on inspector attachWindow $ do
        webview <- webInspectorGetWebView inspector
        case webview of
            Just view -> do 
                widgetHide inspectorWindow
                containerRemove inspectorWindow view
                widgetSetSizeRequest view (-1) 250
                boxPackEnd windowBox view PackNatural 0
                widgetShow view
                return True
            _ -> return False

-- Detach inspector in a distinct window
    _ <- io $ on inspector detachWindow $ do
        webview <- webInspectorGetWebView inspector
        _ <- case webview of
            Just view -> do
                containerRemove windowBox view
                containerAdd inspectorWindow view
                widgetShowAll inspectorWindow
                return True
            _ -> return False
        
        widgetShowAll inspectorWindow
        return True

    return inspectorWindow
-- }}}

-- {{{ Util
-- | Toggle a widget's visibility (provided for convenience).
toggleVisibility :: (MonadIO m, WidgetClass a) => a -> m ()
toggleVisibility widget = io $ do
    visibility <- get widget widgetVisible
    visibility ? widgetHide widget ?? widgetShow widget
-- }}}