module Hbro.StatusBar where
import Hbro.Core
import Hbro.Gui
import Hbro.Types
import Hbro.Util
import Control.Monad hiding(forM_, mapM_)
import Data.Foldable
import Data.List
import Data.Maybe
import Graphics.Rendering.Pango.Enums
import Graphics.Rendering.Pango.Layout
import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.Misc.Adjustment
import Graphics.UI.Gtk.Scrolling.ScrolledWindow
import Graphics.UI.Gtk.WebKit.WebView
import Network.URI
import Prelude hiding(mapM_)
import System.Glib.Signals
setupScrollWidget :: Label -> K ()
setupScrollWidget widget = do
adjustment <- with (mScrollWindow . mGUI) $ scrolledWindowGetVAdjustment
io $ do
labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 32767 32767 32767}]
_ <- onValueChanged adjustment $ do
current <- adjustmentGetValue adjustment
lower <- adjustmentGetLower adjustment
upper <- adjustmentGetUpper adjustment
page <- adjustmentGetPageSize adjustment
case upperlowerpage of
0 -> labelSetText widget "ALL"
x -> labelSetText widget $ show (round $ current/x*100) ++ "%"
labelSetText widget "0%"
setupZoomWidget :: Label -> K ()
setupZoomWidget widget = do
io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 65535 65535 65535}]
with (mWebView . mGUI) webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show
printInLabel :: String -> (String, Bool) -> K (String, Bool)
printInLabel label (keystrokes, match) = do
widget <- getObject castToLabel label
io $ do
labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 65535 65535 0}]
case match of
True -> labelSetText widget []
_ -> labelSetText widget keystrokes
return (keystrokes, match)
setupProgressWidget :: Label -> K ()
setupProgressWidget widget = with (mWebView . mGUI) $ \webView -> do
_ <- on webView loadStarted $ \_ -> do
labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 65535 0 0}]
labelSetText widget "0%"
_ <- on webView progressChanged $ \progress' -> do
labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 65535 65535 0}]
labelSetText widget $ show progress' ++ "%"
_ <- on webView loadFinished $ \_ -> do
labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 0 65535 0}]
labelSetText widget "100%"
_ <- on webView loadError $ \_ _ _ -> do
labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 65535 0 0}]
labelSetText widget "ERROR"
return False
return ()
setupURIWidget :: URIColors -> URIColors -> Label -> K ()
setupURIWidget normalColors secureColors widget = with (mWebView . mGUI) $ \webView -> do
_ <- on webView loadCommitted $ \_ ->
(mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= parseURIReference) `fmap` (webViewGetUri webView))
_ <- on webView hoveringOverLink $ \_title hoveredURI -> do
uri <- webViewGetUri webView
forM_ (hoveredURI >>= parseURIReference) $ labelSetURI normalColors secureColors widget
unless (isJust hoveredURI) $ forM_ (uri >>= parseURIReference) (labelSetURI normalColors secureColors widget)
return ()
labelSetURI :: URIColors -> URIColors -> Label -> URI -> IO ()
labelSetURI normalColors secureColors widget uri = do
let colors = case uriScheme uri of
"https:" -> secureColors
_ -> normalColors
let i:j:k:l:_ = map length [
uriScheme uri,
maybe [] uriRegName (uriAuthority uri),
uriPath uri,
uriQuery uri]
labelSetAttributes widget $ [
AttrWeight{ paStart = 0, paEnd = 1, paWeight = WeightBold },
AttrForeground{ paStart = 0, paEnd = i+2, paColor = mScheme colors },
AttrForeground{ paStart = i+2, paEnd = i+2+j, paColor = mHost colors },
AttrForeground{ paStart = i+2+j, paEnd = i+2+j+k, paColor = mPath colors },
AttrForeground{ paStart = i+2+j+k, paEnd = i+2+j+k+l, paColor = mQuery colors },
AttrForeground{ paStart = i+2+j+k+l, paEnd = 1, paColor = mFragment colors }]
labelSetText widget (show uri)
data URIColors = URIColors {
mScheme :: Color,
mHost :: Color,
mPort :: Color,
mUser :: Color,
mPath :: Color,
mQuery :: Color,
mFragment :: Color
}
defaultURIColors :: URIColors
defaultURIColors = URIColors {
mScheme = Color 20000 20000 20000,
mHost = Color 50000 50000 50000,
mPort = Color 65535 0 0,
mUser = Color 0 65535 0,
mPath = Color 20000 20000 20000,
mQuery = Color 20000 20000 20000,
mFragment = Color 10000 10000 65535
}
defaultSecureURIColors :: URIColors
defaultSecureURIColors = defaultURIColors {
mHost = Color 50000 50000 0
}