diff --git a/Hbro/Core.hs b/Hbro/Core.hs
--- a/Hbro/Core.hs
+++ b/Hbro/Core.hs
@@ -30,6 +30,7 @@
import Network.URL
import System.Console.CmdArgs
+import System.Directory
import System.Glib.Signals
import System.IO
import System.Process
@@ -159,9 +160,13 @@
-- Load homepage
case (mURI options) of
Just uri -> do
- webViewLoadUri webView uri
+ fileURI <- doesFileExist uri
+ case fileURI of
+ True -> getCurrentDirectory >>= \cwd -> webViewLoadUri webView $ "file://" ++ cwd ++ "/" ++ uri
+ _ -> webViewLoadUri webView uri
+
whenLoud $ putStrLn ("Loading " ++ uri ++ "...")
- _ -> goHome browser
+ _ -> goHome browser
-- Initialize IPC socket
@@ -222,16 +227,16 @@
Just url' -> do
whenLoud $ putStrLn ("Loading URI: " ++ url)
loadURI' url' browser
- _ -> return ()
+ _ -> putStrLn $ "WARNING: not a valid URI: " ++ url
-- | Backend function for loadURI.
loadURI' :: URL -> Browser -> IO ()
-loadURI' url@URL {url_type = Absolute _} browser =
- webViewLoadUri (mWebView $ mGUI browser) (exportURL url)
-loadURI' url@URL {url_type = HostRelative} browser =
- webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url)
-loadURI' url@URL {url_type = _} browser =
- webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url)
+loadURI' uri@URL {url_type = Absolute _} browser =
+ webViewLoadUri (mWebView $ mGUI browser) (exportURL uri)
+loadURI' uri@URL {url_type = HostRelative} browser =
+ webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL uri)
+loadURI' uri@URL {url_type = _} browser =
+ webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL uri)
-- }}}
diff --git a/Hbro/Extra/StatusBar.hs b/Hbro/Extra/StatusBar.hs
--- a/Hbro/Extra/StatusBar.hs
+++ b/Hbro/Extra/StatusBar.hs
@@ -6,6 +6,9 @@
import Control.Monad.Trans(liftIO)
+import Data.List
+
+import Graphics.Rendering.Pango.Enums
import Graphics.Rendering.Pango.Layout
import Graphics.UI.Gtk.Abstract.Widget
@@ -16,6 +19,8 @@
import Graphics.UI.Gtk.Scrolling.ScrolledWindow
import Graphics.UI.Gtk.WebKit.WebView
+import Network.URL
+
import System.Glib.Signals
-- }}}
@@ -66,7 +71,10 @@
builder = mBuilder (mGUI browser)
webView = mWebView (mGUI browser)
in do
- keysLabel <- builderGetObject builder castToLabel "keys"
+ keysLabel <- builderGetObject builder castToLabel "keys"
+ labelSetAttributes keysLabel [
+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}
+ ]
_ <- after webView keyPressEvent $ do
value <- eventKeyVal
@@ -74,8 +82,8 @@
let keyString = keyToString value
case (keyString, modifiers) of
- (Just k, []) -> liftIO $ labelSetMarkup keysLabel $ "" ++ escapeMarkup k ++ ""
- (Just k, m) -> liftIO $ labelSetMarkup keysLabel $ "" ++ show m ++ escapeMarkup k ++ ""
+ (Just k, []) -> liftIO $ labelSetText keysLabel k
+ (Just k, m) -> liftIO $ labelSetText keysLabel (show m ++ k)
_ -> return ()
return False
@@ -90,20 +98,33 @@
builder = mBuilder (mGUI browser)
webView = mWebView (mGUI browser)
in do
- progressLabel <- builderGetObject builder castToLabel "progress"
-
+ progressLabel <- builderGetObject builder castToLabel "progress"
+-- Load started
_ <- on webView loadStarted $ \_ -> do
- labelSetMarkup progressLabel "0%"
-
- _ <- on webView progressChanged $ \progress' ->
- labelSetMarkup progressLabel $ "" ++ show progress' ++ "%"
-
+ labelSetAttributes progressLabel [
+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}
+ ]
+ labelSetText progressLabel "0%"
+-- Progress changed
+ _ <- on webView progressChanged $ \progress' -> do
+ labelSetAttributes progressLabel [
+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}
+ ]
+ labelSetText progressLabel $ show progress' ++ "%"
+-- Load finished
_ <- on webView loadFinished $ \_ -> do
- labelSetMarkup progressLabel "100%"
-
+ labelSetAttributes progressLabel [
+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}
+ ]
+ labelSetText progressLabel "100%"
+-- Error
_ <- on webView loadError $ \_ _ _ -> do
- labelSetMarkup progressLabel "ERROR"
+ labelSetAttributes progressLabel [
+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}
+ ]
+ labelSetText progressLabel "ERROR"
return False
+
return ()
@@ -112,28 +133,59 @@
statusBarURI :: Browser -> IO ()
statusBarURI browser = do
uriLabel <- builderGetObject builder castToLabel "uri"
-
+-- URI changed
_ <- on webView loadCommitted $ \_ -> do
- getUri <- (webViewGetUri webView)
- let (color, uri) = case getUri of
- Just (u@('h':'t':'t':'p':'s':_)) -> ("orange", u)
- Just u -> ("gray", u)
- _ -> ("red", "ERROR")
-
- labelSetMarkup uriLabel $ "" ++ escapeMarkup uri ++ ""
+ getUri <- (webViewGetUri webView)
+ maybe (return ()) (\x -> setURILabel x uriLabel) getUri
+-- Hovering link
_ <- on webView hoveringOverLink $ \_title hoveredUri -> do
getUri <- (webViewGetUri webView)
- let (color, uri) = case (hoveredUri, getUri) of
- (Just u, _) -> ("#5555ff", u)
- (_, Just (u@('h':'t':'t':'p':'s':_))) -> ("orange", u)
- (_, Just u) -> ("white", u)
- _ -> ("red", "ERROR")
+ let uri = case (hoveredUri, getUri) of
+ (Just u, _) -> u
+ (_, Just u) -> u
+ (_, _) -> "ERROR"
- labelSetMarkup uriLabel $ "" ++ escapeMarkup uri ++ ""
+ setURILabel uri uriLabel
+
return ()
where
builder = mBuilder (mGUI browser)
webView = mWebView (mGUI browser)
-
+ setURILabel uri label = do
+ let uri' = importURL uri
+ case uri' of
+ Just u -> do
+ case url_type u of
+ Absolute host -> do
+ let host' = exportHost host
+ let secure' = secure host
+ let protocolColor = Color 20000 20000 20000
+ let hostColor = case secure' of
+ True -> Color 0 65535 0
+ _ -> Color 50000 50000 50000
+ let pathColor = Color 20000 20000 65535
+ let parametersColor = Color 20000 20000 20000
+ let i = findIndex (isPrefixOf "://") (tails host')
+ let j = length host'
+
+
+ let colorAttributes = case i of
+ Just n -> [
+ AttrForeground {paStart = 0, paEnd = n+3, paColor = protocolColor},
+ AttrForeground {paStart = n+3, paEnd = j, paColor = hostColor},
+ AttrForeground {paStart = j, paEnd = -1, paColor = pathColor}
+ ]
+ _ -> [
+ AttrForeground {paStart = 0, paEnd = j, paColor = hostColor},
+ AttrForeground {paStart = j, paEnd = -1, paColor = pathColor}
+ ]
+
+
+ labelSetAttributes label $ [AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}] ++ colorAttributes
+
+ labelSetText label uri
+ _ -> return ()
+ _ -> return ()
+
diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs
--- a/Hbro/Gui.hs
+++ b/Hbro/Gui.hs
@@ -6,6 +6,7 @@
import Control.Monad.Trans(liftIO)
+import Graphics.Rendering.Pango.Enums
import Graphics.UI.Gtk.Abstract.Container
import Graphics.UI.Gtk.Abstract.Widget
import Graphics.UI.Gtk.Builder
@@ -44,15 +45,18 @@
-- Load main window
window <- builderGetObject builder castToWindow "mainWindow"
- windowSetDefault window (Just webView)
+ windowSetDefault window $ Just webView
scrollWindow <- builderGetObject builder castToScrolledWindow "webViewParent"
containerAdd scrollWindow webView
- set scrollWindow [
- scrolledWindowHscrollbarPolicy := PolicyNever,
- scrolledWindowVscrollbarPolicy := PolicyNever ]
+ scrolledWindowSetPolicy scrollWindow PolicyNever PolicyNever
promptLabel <- builderGetObject builder castToLabel "promptDescription"
+ labelSetAttributes promptLabel [
+ AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic},
+ AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}
+ ]
+
promptEntry <- builderGetObject builder castToEntry "promptEntry"
statusBox <- builderGetObject builder castToHBox "statusBox"
diff --git a/hbro.cabal b/hbro.cabal
--- a/hbro.cabal
+++ b/hbro.cabal
@@ -1,5 +1,5 @@
Name: hbro
-Version: 0.6.8.1
+Version: 0.6.8.2
Synopsis: A minimal KISS compliant browser
-- Description:
Homepage: http://projects.haskell.org/hbro/
@@ -17,9 +17,9 @@
Extra-source-files: examples/hbro.hs
Data-files: examples/ui.xml
---Source-repositVory head
--- Type: git
--- Location: git@twyk.tk/haskell-browser.git
+Source-repository head
+ Type: git
+ Location: git@twyk.org/haskell-browser.git
Library
Build-depends: