diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -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: diff --git a/src/Browser.hs b/src/Browser.hs new file mode 100644 --- /dev/null +++ b/src/Browser.hs @@ -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"] +} +-- }}} diff --git a/src/Gui.hs b/src/Gui.hs new file mode 100644 --- /dev/null +++ b/src/Gui.hs @@ -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 () +-- diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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 "" 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 "" + 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 ++ ">")