tianbar 0.1.2.0 → 0.1.3.0
raw patch · 6 files changed
+228/−6 lines, 6 files
Files
- src/System/Tianbar.hs +48/−0
- src/System/Tianbar/Configuration.hs +17/−0
- src/System/Tianbar/StrutProperties.hs +35/−0
- src/System/Tianbar/Systray.hs +25/−0
- src/System/Tianbar/WebKit.hs +92/−0
- tianbar.cabal +11/−6
+ src/System/Tianbar.hs view
@@ -0,0 +1,48 @@+module System.Tianbar where++import Graphics.UI.Gtk hiding (Signal)++import System.Tianbar.Configuration+import System.Tianbar.Systray+import System.Tianbar.StrutProperties+import System.Tianbar.WebKit++topStrut :: Rectangle -> StrutProperties+topStrut (Rectangle mX mY mW _) = (0, 0, h, 0, 0, 0, 0, 0, x, x + w, 0, 0)+ where x = mX+ w = mW - 1+ h = barHeight + mY++main :: IO ()+main = do+ _ <- initGUI++ Just disp <- displayGetDefault+ screen <- displayGetScreen disp myScreen+ monitorSize <- screenGetMonitorGeometry screen myMonitor++ window <- windowNew+ widgetSetName window appName++ let Rectangle x _ w _ = monitorSize+ windowSetTypeHint window WindowTypeHintDock+ windowSetScreen window screen+ windowSetDefaultSize window w barHeight+ windowMove window x 0+ _ <- onRealize window $+ setStrutProperties window $ topStrut monitorSize++ box <- hBoxNew False widgetSpacing+ containerAdd window box++ wk <- xmonadWebkitLogNew+ boxPackStart box wk PackGrow 0++ tray <- systrayNew+ boxPackEnd box tray PackNatural 0++ widgetShow window+ widgetShow box++ mainGUI+ return ()
+ src/System/Tianbar/Configuration.hs view
@@ -0,0 +1,17 @@+module System.Tianbar.Configuration where++appName :: String+appName = "tianbar"++myScreen :: Int+myScreen = 0++myMonitor :: Int+myMonitor = 0++barHeight :: Int+barHeight = 25++widgetSpacing :: Int+widgetSpacing = 0+
+ src/System/Tianbar/StrutProperties.hs view
@@ -0,0 +1,35 @@+module System.Tianbar.StrutProperties ( setStrutProperties+ , StrutProperties ) where++import Graphics.UI.Gtk++import Foreign+import Foreign.C.Types+import Unsafe.Coerce ( unsafeCoerce )++type StrutProperties = (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)++foreign import ccall "set_strut_properties"+ c_set_strut_properties :: Ptr Window -> CLong -> CLong -> CLong -> CLong+ -> CLong -> CLong+ -> CLong -> CLong+ -> CLong -> CLong+ -> CLong -> CLong+ -> ()++-- | Reserve EWMH struts+setStrutProperties :: Window -> StrutProperties -> IO ()+setStrutProperties gtkWindow (left, right, top, bottom,+ left_start_y, left_end_y,+ right_start_y, right_end_y,+ top_start_x, top_end_x,+ bottom_start_x, bottom_end_x) = do+ let ptrWin = unsafeCoerce gtkWindow :: ForeignPtr Window+ let fi = fromIntegral+ withForeignPtr ptrWin $ \realPointer -> do+ return $ c_set_strut_properties realPointer (fi left) (fi right) (fi top) (fi bottom)+ (fi left_start_y) (fi left_end_y)+ (fi right_start_y) (fi right_end_y)+ (fi top_start_x) (fi top_end_x)+ (fi bottom_start_x) (fi bottom_end_x)+
+ src/System/Tianbar/Systray.hs view
@@ -0,0 +1,25 @@+-- | This is a very basic system tray widget. That said, it works+-- very well since it is based on eggtraymanager.+module System.Tianbar.Systray ( systrayNew ) where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.Misc.TrayManager++import System.Tianbar.Configuration++systrayNew :: IO Widget+systrayNew = do+ box <- hBoxNew False 5++ trayManager <- trayManagerNew+ Just screen <- screenGetDefault+ _ <- trayManagerManageScreen trayManager screen++ _ <- on trayManager trayIconAdded $ \w -> do+ widgetShowAll w+ boxPackStart box w PackNatural 0++ widgetSetSizeRequest box (-1) barHeight++ widgetShowAll box+ return (toWidget box)
+ src/System/Tianbar/WebKit.hs view
@@ -0,0 +1,92 @@+module System.Tianbar.WebKit where++import Control.Monad++import Data.List+import Data.List.Split+import Data.List.Utils++import DBus (fromVariant, Signal(..), parseObjectPath, parseInterfaceName, parseMemberName)+import DBus.Client (listen, matchAny, MatchRule(..), connectSession)++import Graphics.UI.Gtk hiding (Signal)+import Graphics.UI.Gtk.WebKit.NetworkRequest+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebSettings++import System.Environment.XDG.BaseDir++import System.Process++import System.Tianbar.Configuration++gsettingsGet :: String -> String -> IO String+gsettingsGet schema key = do+ output <- readProcess "gsettings" ["get", schema, key] []+ let len = length output+ return $ drop 1 $ take (len - 2) output++gsettingsPrefix :: String+gsettingsPrefix = "gsettings:"++setupWebkitLog :: WebView -> IO ()+setupWebkitLog wk = do+ let matcher = matchAny { matchSender = Nothing+ , matchDestination = Nothing+ , matchPath = parseObjectPath "/org/xmonad/Log"+ , matchInterface = parseInterfaceName "org.xmonad.Log"+ , matchMember = parseMemberName "Update"+ }++ wsettings <- webViewGetWebSettings wk+ set wsettings [webSettingsEnableUniversalAccessFromFileUris := True]+ webViewSetWebSettings wk wsettings++ _ <- on wk resourceRequestStarting $ \_ _ nreq _ -> case nreq of+ Nothing -> return ()+ (Just req) -> do+ uri_ <- networkRequestGetUri req+ case uri_ of+ Nothing -> return ()+ Just uri -> when (gsettingsPrefix `isPrefixOf` uri) $ do+ let path = drop (length gsettingsPrefix) uri+ let [schema, key] = splitOn "/" path+ setting <- gsettingsGet schema key+ networkRequestSetUri req $+ "data:text/plain," ++ setting++ htmlFile <- getUserConfigFile appName "index.html"+ html <- readFile htmlFile+ webViewLoadHtmlString wk html $ "file://" ++ htmlFile++ client <- connectSession++ listen client matcher $ callback wk++escapeQuotes :: String -> String+escapeQuotes = replace "'" "\\'" . replace "\\" "\\\\"++callback :: WebView -> Signal -> IO ()+callback wk sig = do+ let [bdy] = signalBody sig+ Just status = fromVariant bdy+ postGUIAsync $ webViewExecuteScript wk $ setStatus status++setStatus :: String -> String+setStatus status = let statusStr = escapeQuotes status in+ "window.setXMonadStatus ? window.setXMonadStatus('" ++ statusStr ++ "')" +++ " : window.XMonadStatus = '" ++ statusStr ++ "'"++xmonadWebkitLogNew :: IO Widget+xmonadWebkitLogNew = do+ l <- webViewNew++ _ <- on l realize $ setupWebkitLog l++ Just disp <- displayGetDefault+ screen <- displayGetScreen disp myScreen+ (Rectangle _ _ sw _) <- screenGetMonitorGeometry screen myMonitor+ _ <- on l sizeRequest $ return (Requisition (sw `div` 2) barHeight)++ widgetShowAll l+ return (toWidget l)
tianbar.cabal view
@@ -1,5 +1,5 @@ name: tianbar-version: 0.1.2.0+version: 0.1.3.0 synopsis: A desktop bar based on WebKit description: A desktop bar using WebKit for rendering as much as possible.@@ -15,7 +15,6 @@ executable tianbar default-language: Haskell2010- main-is: Main.hs build-depends: base ==4.6.* , split ==0.2.* , MissingH ==1.2.*@@ -25,11 +24,17 @@ , webkit ==0.12.* , xdg-basedir ==0.2.* , process ==1.1.*- hs-source-dirs: src pkgconfig-depends: gtk+-2.0- c-sources: src/gdk_property_change_wrapper.c- ghc-options: -Wall -rtsopts -threaded- ghc-prof-options: -auto-all+ hs-source-dirs: src+ main-is: Main.hs+ other-modules: System.Tianbar+ , System.Tianbar.Configuration+ , System.Tianbar.StrutProperties+ , System.Tianbar.Systray+ , System.Tianbar.WebKit+ c-sources: src/gdk_property_change_wrapper.c+ ghc-options: -Wall -rtsopts -threaded+ ghc-prof-options: -auto-all library default-language: Haskell2010