hbro 0.4.3 → 0.4.4
raw patch · 3 files changed
+51/−19 lines, 3 files
Files
- Hbro/Gui.hs +22/−13
- examples/Main.hs +27/−4
- hbro.cabal +2/−2
Hbro/Gui.hs view
@@ -9,15 +9,17 @@ -- }}} 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+ mWindow :: Window, -- ^ Main window+ mInspectorWindow :: Window, -- ^ WebInspector window+ mScrollWindow :: ScrolledWindow, -- ^ ScrolledWindow containing the webview+ 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+ mUrlLabel :: Label,+ mScrollLabel :: Label } -- {{{ Load glade GUI@@ -46,33 +48,40 @@ winBox <- vBoxNew False 0 promptBox <- hBoxNew False 10 statusBox <- hBoxNew False 5- scrollWin <- scrolledWindowNew Nothing Nothing+ scrollWindow <- scrolledWindowNew Nothing Nothing promptLabel <- labelNew Nothing promptEntry <- entryNew progressLabel <- labelNew (Just "0%") urlLabel <- labelNew (Just "")+ scrollLabel <- labelNew (Just "0%") - boxPackStart winBox scrollWin PackGrow 0+ boxPackStart winBox scrollWindow 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+ boxPackEnd statusBox scrollLabel PackNatural 0+ window `containerAdd` winBox- scrollWin `containerAdd` webView+ scrollWindow `containerAdd` webView set webView [ widgetCanDefault := True ] windowSetDefault window (Just webView)+ set scrollWindow [+ scrolledWindowHscrollbarPolicy := PolicyNever,+ scrolledWindowVscrollbarPolicy := PolicyNever ] _ <- on webView closeWebView $ do mainQuit return True - return $ GUI window inspectorWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel+ return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel scrollLabel -- }}} +-- {{{ Prompt -- | Show or hide the prompt bar (label + entry). showPrompt :: Bool -> GUI -> IO () showPrompt toShow gui = case toShow of@@ -135,4 +144,4 @@ return False return ()-+-- }}}
examples/Main.hs view
@@ -13,7 +13,7 @@ import Graphics.UI.Gtk.WebKit.WebNavigationAction import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.WebSettings-import System.Cmd+import System.Process -- }}} main :: IO ()@@ -103,17 +103,31 @@ -- Custom callbacks mCustomizations = \gui -> (let webView = mWebView gui+ scrollWindow = mScrollWindow gui progressLabel = mProgressLabel gui urlLabel = mUrlLabel gui+ scrollLabel = mScrollLabel gui window = mWindow gui in do+ widgetModifyBg window StateNormal (Color 0 0 10000)+ adjustment <- scrolledWindowGetVAdjustment scrollWindow++ -- Scroll position+ onValueChanged adjustment $ do+ current <- adjustmentGetValue adjustment+ min <- adjustmentGetLower adjustment+ max <- adjustmentGetUpper adjustment+ page <- adjustmentGetPageSize adjustment+ + labelSetMarkup scrollLabel $ (show (round $ current/(max-min-page)*100)) ++ "%"+ _ <- on webView loadStarted $ \_ -> do labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>" _ <- on webView loadCommitted $ \_ -> do getUrl <- (webViewGetUri webView) case getUrl of - Just url -> labelSetMarkup urlLabel url + Just url -> labelSetMarkup urlLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ url ++ "</span>" _ -> labelSetMarkup urlLabel "" _ <- on webView progressChanged $ \progress' ->@@ -122,7 +136,13 @@ _ <- on webView loadFinished $ \_ -> do labelSetMarkup progressLabel "<span foreground=\"green\">100%</span>" + getUri <- webViewGetUri webView+ getTitle <- webViewGetTitle webView+ case (getUri, getTitle) of+ (Just uri, Just title) -> (runCommand $ scriptsDir ++ "/historyHandler.sh \"" ++ uri ++ "\" \"" ++ title ++ "\"") >> return ()+ _ -> return () + _ <- on webView loadError $ \_ _ _ -> do labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>" return False@@ -133,8 +153,8 @@ _ <- on webView downloadRequested $ \download -> do getUrl <- downloadGetUri download _ <- case getUrl of- Just url -> forkOS $ (rawSystem "wget" [url]) >> return ()- _ -> forkOS $ return ()+ Just url -> runExternalCommand $ "wget \"" ++ url ++ "\""+ _ -> return () return True _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do@@ -181,6 +201,9 @@ -- Definitions where+ scriptsDir :: String+ scriptsDir = "~/.config/hbro/scripts/"+ goBack :: GUI -> IO () goBack gui = webViewGoBack (mWebView gui)
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.4.3+Version: 0.4.4 Synopsis: A suckless minimal KISSy browser -- Description: -- Homepage:@@ -44,7 +44,7 @@ Hbro.Gui, Hbro.Socket Hbro.Util- Ghc-options: -Wall -threaded + Ghc-options: -Wall Executable hbro Build-depends: