hbro 0.1 → 0.1.1
raw patch · 4 files changed
+313/−3 lines, 4 files
Files
- hbro.cabal +3/−3
- src/Browser.hs +141/−0
- src/Gui.hs +144/−0
- src/Util.hs +25/−0
hbro.cabal view
@@ -3,8 +3,8 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1-Synopsis: A suckless minimalist KISSy browser+Version: 0.1.1+Synopsis: A suckless minimal KISSy browser stability: alpha -- A longer description of the package.@@ -40,7 +40,7 @@ Build-depends: base == 4.*, webkit, gtk, glade, mtl, containers, dyre, process, url -- Modules not exported by this package.- -- Other-modules: + Other-modules: Gui Browser Util -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools:
+ src/Browser.hs view
@@ -0,0 +1,141 @@+module Browser where++-- {{{ Imports+import Gui+import Util++import qualified Config.Dyre as Dyre++import Control.Monad.Trans(liftIO)+import Data.Map+import Graphics.UI.Gtk+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebInspector+import Graphics.UI.Gtk.WebKit.WebSettings+import Network.URL+import Prelude hiding (lookup)+import System.Environment+-- }}}++-- {{{ Type definitions+data Browser = Browser {+ mGUI :: GUI+}++data Configuration = Configuration {+ mHomePage :: String, -- ^ Startup page + mKeyBindings :: [(([Modifier], String), GUI -> IO ())], -- ^ List of keybindings+ mWebSettings :: IO WebSettings, -- ^ Web settings+ mCustomizations :: GUI -> IO (), -- ^ Custom callbacks+ mError :: Maybe String -- ^ Error+}++instance Ord Modifier where+ m <= m' = fromEnum m <= fromEnum m'+-- }}}++-- {{{ Entry point+-- | Entry point of the application.+-- Check if help display is requested.+realMain :: Configuration -> IO ()+realMain configuration = do+ args <- getArgs++ case args of+ ["--help"] -> putStrLn "Usage: browser [url]"+ _ -> initBrowser configuration+-- }}}++-- {{{ Main function+-- | Application's main function.+-- Create browser and load homepage.+initBrowser :: Configuration -> IO ()+initBrowser configuration = do+ -- Initialize GUI+ args <- initGUI+ gui <- loadGUI ""++ -- Load configuration+ settings <- mWebSettings configuration+ webViewSetWebSettings (mWebView gui) settings+ (mCustomizations configuration) gui++ -- Load url+ let url = case args of+ [arg] -> arg+ _ -> mHomePage configuration++ webViewLoadUri (mWebView gui) url++ -- Load key bindings+ let keyBindings = fromList (mKeyBindings configuration)++ -- Open all link in current window.+ _ <- on (mWebView gui) createWebView $ \frame -> do+ newUri <- webFrameGetUri frame+ case newUri of+ Just uri -> webViewLoadUri (mWebView gui) uri+ Nothing -> return ()+ return (mWebView gui)++ -- Key bindings+ _ <- after (mWebView gui) keyPressEvent $ do+ keyVal <- eventKeyVal+ modifiers <- eventModifier++ let keyString = keyToString keyVal++ case keyString of + Just string -> do + case lookup (modifiers, string) keyBindings of+ Just callback -> liftIO $ callback gui+ _ -> liftIO $ putStrLn "No callback associated"+ liftIO $ putStrLn string+ _ -> return ()++ return False++ -- Connect and show.+ _ <- onDestroy (mWindow gui) mainQuit+ widgetShowAll (mWindow gui)+ widgetHide (mPromptLabel gui)+ widgetHide (mPrompt gui)++ mainGUI+-- }}}++-- | Show web inspector for current webpage.+showWebInspector :: GUI -> IO ()+showWebInspector gui = do+ inspector <- webViewGetInspector (mWebView gui)+ webInspectorShow inspector++-- | Load given URL in the browser.+loadURL :: String -> GUI -> IO ()+loadURL url gui =+ case importURL url of+ Just url -> loadURL' url gui+ _ -> return ()++-- | Backend function for loadURL.+loadURL' :: URL -> GUI -> IO ()+loadURL' url@URL {url_type = Absolute _} gui =+ webViewLoadUri (mWebView gui) (exportURL url)+loadURL' url@URL {url_type = HostRelative} gui = + webViewLoadUri (mWebView gui) ("file://" ++ exportURL url) >> putStrLn (show url)+loadURL' url@URL {url_type = _} gui = + webViewLoadUri (mWebView gui) ("http://" ++ exportURL url) >> print url++-- {{{ Dyre+showError :: Configuration -> String -> Configuration+showError configuration message = configuration { mError = Just message }++browser :: Configuration -> IO ()+browser = Dyre.wrapMain Dyre.defaultParams {+ Dyre.projectName = "browser",+ Dyre.showError = showError,+ Dyre.realMain = realMain,+ Dyre.ghcOpts = ["-i /path/to/src", "-O2"]+}+-- }}}
+ src/Gui.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE DoRec #-}+module Gui where++-- {{{ Imports+import Control.Monad.Trans(liftIO)++import Graphics.UI.Gtk+import Graphics.UI.Gtk.WebKit.WebView+-- }}}++data GUI = GUI {+ mWindow :: Window, -- ^ Main window+ mWebView :: WebView, -- ^ Browser's webview+ mPromptLabel :: Label, -- ^ Description of current prompt+ mPrompt :: Entry, -- ^ Prompt entry+ mStatusBox :: HBox, -- ^ Status bar's layout+ mProgressLabel :: Label,+ mUrlLabel :: Label+}++-- {{{ Load glade GUI+-- | Load GUI from a glade file.+loadGUI :: String -> IO GUI+loadGUI gladePath = do+-- -- Note: crashes with a runtime error on console if fails!+-- Just xml <- xmlNew gladePath++-- -- Load main window+-- -- castTo* don't exist :(+-- window <- xmlGetWidget xml castToWindow "window"+-- webView <- xmlGetWidget xml castToWebView "webView"+-- promptLabel <- xmlGetWidget xml castToLabel "promptLabel"+-- prompt <- xmlGetWidget xml castToEntry "prompt"++ window <- windowNew+ windowSetDefaultSize window 1024 768+ windowSetPosition window WinPosCenter+ --windowSetOpacity window 0.8 + --windowSetIconFromFile window "/path/to/icon"+ set window [ windowTitle := "Browser" ]++ webView <- webViewNew+ winBox <- vBoxNew False 0+ promptBox <- hBoxNew False 10+ statusBox <- hBoxNew False 5+ scrollWin <- scrolledWindowNew Nothing Nothing+ promptLabel <- labelNew Nothing+ promptEntry <- entryNew+ progressLabel <- labelNew (Just "0%")+ urlLabel <- labelNew (Just "")++ boxPackStart winBox scrollWin 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++ window `containerAdd` winBox+ scrollWin `containerAdd` webView++ _ <- on webView closeWebView $ do+ mainQuit+ return True+++ webFrame <- webViewGetMainFrame webView++ return $ GUI window webView promptLabel promptEntry statusBox progressLabel urlLabel+-- }}}++-- | Show or hide the prompt bar (label + entry).+showPrompt :: Bool -> GUI -> IO ()+showPrompt toShow gui = case toShow of+ False -> do widgetHide (mPromptLabel gui)+ widgetHide (mPrompt gui)+ _ -> do widgetShow (mPromptLabel gui)+ widgetShow (mPrompt gui)++-- | Show the prompt bar label and default text.+-- As the user validates its entry, the given callback is executed.+prompt :: String -> String -> GUI -> (GUI -> IO ()) -> IO ()+prompt label defaultText gui callback = do+ -- Show prompt+ showPrompt True gui++ -- Fill prompt+ labelSetText (mPromptLabel gui) label+ entrySetText (mPrompt gui) defaultText++ widgetGrabFocus (mPrompt gui)++ -- Register callback+ rec id <- on (mPrompt gui) keyPressEvent $ do+ key <- eventKeyName++ case key of+ "Return" -> do liftIO $ showPrompt False gui+ liftIO $ callback gui+ liftIO $ signalDisconnect id+ liftIO $ widgetGrabFocus (mWebView gui)+ "Escape" -> do liftIO $ showPrompt False gui+ liftIO $ signalDisconnect id+ liftIO $ widgetGrabFocus (mWebView gui)+ _ -> return ()++ return False++ return ()+++-- promptFind :: Maybe String -> GUI -> IO ()+-- promptFind label gui = do+-- -- Show prompt+-- widgetShow (mPromptLabel gui)+-- widgetShow (mPrompt gui)++-- -- Fill prompt+-- case label of+-- Just text -> labelSetText (mPromptLabel gui) text+-- _ -> return ()++-- widgetGrabFocus (mPrompt gui)++-- -- Register callback+-- rec id <- on (mPrompt gui) keyPressEvent $ do+-- key <- eventKeyName+-- --keywords <- entryGetText (mPrompt gui)++-- case key of+-- "Return" -> do liftIO $ widgetHide (mPromptLabel gui)+-- liftIO $ widgetHide (mPrompt gui)+-- liftIO $ webViewMarkTextMatches (mWebView gui) keywords True 0+-- liftIO $ signalDisconnect id+-- "Escape" -> do liftIO $ widgetHide (mPromptLabel gui)+-- liftIO $ widgetHide (mPrompt gui)+-- liftIO $ signalDisconnect id+-- _ -> return ()++-- return False++-- return ()+--
+ src/Util.hs view
@@ -0,0 +1,25 @@+module Util where++import Graphics.UI.Gtk++-- |Converts a keyVal to a String.+-- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned.+-- For non-printable characters, the corresponding keyName between <> is returned.+-- For modifiers, Nothing is returned.+keyToString :: KeyVal -> Maybe String+keyToString keyVal = case keyToChar keyVal of+ Just ' ' -> Just "<Space>"+ Just char -> Just [char]+ _ -> case keyName keyVal of+ "Caps_Lock" -> Nothing+ "Shift_L" -> Nothing+ "Shift_R" -> Nothing+ "Control_L" -> Nothing+ "Control_R" -> Nothing+ "Alt_L" -> Nothing+ "Alt_R" -> Nothing+ "Super_L" -> Nothing+ "Super_R" -> Nothing+ "Menu" -> Nothing+ "ISO_Level3_Shift" -> Nothing+ x -> Just ('<':x ++ ">")