hbro 0.6.8.1 → 0.6.8.2
raw patch · 4 files changed
+106/−45 lines, 4 files
Files
- Hbro/Core.hs +14/−9
- Hbro/Extra/StatusBar.hs +80/−28
- Hbro/Gui.hs +8/−4
- hbro.cabal +4/−4
Hbro/Core.hs view
@@ -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) -- }}}
Hbro/Extra/StatusBar.hs view
@@ -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 $ "<span foreground=\"green\">" ++ escapeMarkup k ++ "</span>"- (Just k, m) -> liftIO $ labelSetMarkup keysLabel $ "<span foreground=\"green\">" ++ show m ++ escapeMarkup k ++ "</span>"+ (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 "<span foreground=\"red\">0%</span>"- - _ <- on webView progressChanged $ \progress' ->- labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>"-+ 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 "<span foreground=\"green\">100%</span>"-+ labelSetAttributes progressLabel [+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}+ ]+ labelSetText progressLabel "100%"+-- Error _ <- on webView loadError $ \_ _ _ -> do- labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>"+ 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 $ "<span weight=\"bold\" foreground=\"" ++ color ++ "\">" ++ escapeMarkup uri ++ "</span>"+ 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 $ "<span weight=\"bold\" foreground=\"" ++ color ++ "\">" ++ escapeMarkup uri ++ "</span>"+ 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 ()+
Hbro/Gui.hs view
@@ -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"
hbro.cabal view
@@ -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: