diff --git a/src/XBattBar/Backend.hs b/src/XBattBar/Backend.hs --- a/src/XBattBar/Backend.hs +++ b/src/XBattBar/Backend.hs @@ -1,5 +1,4 @@ module XBattBar.Backend (getCharge, getPower, Power(..)) where -import System.Environment data Power = AC | Battery deriving (Show) diff --git a/src/XBattBar/Core.hs b/src/XBattBar/Core.hs --- a/src/XBattBar/Core.hs +++ b/src/XBattBar/Core.hs @@ -1,18 +1,15 @@ module XBattBar.Core (start) where import Prelude hiding (Left, Right) -import Data.Word -import Data.Bits -import Control.Monad +import Data.Bits ((.|.)) +import Control.Monad (forever) import Graphics.X11.Types import Graphics.X11.Xlib.Types hiding (Position) import Graphics.X11.Xlib.Display -import Graphics.X11.Xlib.Window +import Graphics.X11.Xlib.Window (raiseWindow) import Graphics.X11.Xlib.Event -import Graphics.X11.Xlib.Misc -import Graphics.X11.Xlib.Context -import Graphics.X11.Xlib.Color -import Graphics.X11.Xlib.Extras (unmapWindow) +import Graphics.X11.Xlib.Color hiding (allocColor) import System.Posix.IO.Select +import System.Posix.IO.Select.Types import System.Posix.Types import System.Time (getClockTime, ClockTime) @@ -64,28 +61,28 @@ start :: Options -> IO () start opts = do - dpy <- openDisplay "" - let screen = defaultScreen dpy - root <- rootWindow dpy screen - let ctx = XContext dpy screen root - let geom = getBarRect (position opts) (fromIntegral $ thickness opts) (getScreenRect ctx) - let fg = whitePixel dpy screen - let bg = blackPixel dpy screen + dpy' <- openDisplay "" + let screen' = defaultScreen dpy' + root <- rootWindow dpy' screen' + let ctx = XContext dpy' screen' root + let geom' = getBarRect (position opts) (fromIntegral $ thickness opts) (getScreenRect ctx) + let fg = whitePixel dpy' screen' + let bg = blackPixel dpy' screen' let orientation' x | x == Top || x == Bottom = Horizontal | otherwise = Vertical - bar' <- mkProgressBar ctx geom fg bg (orientation' $ position opts) (exposureMask .|. enterWindowMask .|. leaveWindowMask) + bar' <- mkProgressBar ctx geom' fg bg (orientation' $ position opts) (exposureMask .|. enterWindowMask .|. leaveWindowMask) let popupGeom = getPopupRect $ getScreenRect ctx popup' <- mkLabel ctx popupGeom bg fg "fixed" [] noEventMask (ac, bat) <- getColors ctx opts run $ XBattBar opts bar' popup' ac bat return () -handleTimeout :: XBattBar -> Double -> Power -> IO () -handleTimeout xbb charge state = drawWidget (bar xbb) +handleTimeout :: XBattBar -> IO () +handleTimeout xbb = drawWidget (bar xbb) -- | dispatch X11 events to widgets -handleEvents :: XBattBar -> Double -> Power -> IO () -handleEvents xbb charge state = do +handleEvents :: XBattBar -> IO () +handleEvents xbb = do let bar' = bar xbb popup' = popup xbb dpy' = dpy $ xContext bar' @@ -94,20 +91,22 @@ n <- pending dpy' case n of 0 -> return () - _ -> allocaXEvent $ \e -> do - nextEvent dpy' e - t <- get_EventType e - w <- get_Window e - let dispatch w e t | t == enterNotify = displayWidget popup' >> drawWidget popup' + _ -> allocaXEvent $ \ev -> do + nextEvent dpy' ev + ty <- get_EventType ev + win <- get_Window ev + let dispatch w e t | t == enterNotify = displayWidget popup' >> + drawWidget popup' >> + raiseWindow dpy' popupWin | t == leaveNotify = hideWidget popup' | w == barWin = handleWidgetEvent bar' e t | w == popupWin = handleWidgetEvent popup' e t | otherwise = return () - dispatch w e t - handleEvents xbb charge state + dispatch win ev ty + handleEvents xbb selectWrapper fd int eventH timeoutH = do - n <- select [fd] [] [] (Time int 0) + n <- select'' [fd] [] [] (Time $ CTimeval int 0) case n of -1 -> error "select() error" 0 -> return timeoutH @@ -139,9 +138,8 @@ run :: XBattBar -> IO () run xbb = do let bar' = bar xbb - popup' = popup xbb dpy' = dpy $ xContext bar' - int = interval $ options xbb + int = fromIntegral $ interval $ options xbb displayWidget bar' sync dpy' False let fd = Fd $ connectionNumber dpy' @@ -151,4 +149,4 @@ t <- getClockTime let xbb' = applyState xbb c s t drawWidget $ bar xbb' - selectWrapper fd int handleEvents handleTimeout >>= (\h -> h xbb' c s) + selectWrapper fd int handleEvents handleTimeout >>= (\h -> h xbb') diff --git a/src/XBattBar/Types.hs b/src/XBattBar/Types.hs --- a/src/XBattBar/Types.hs +++ b/src/XBattBar/Types.hs @@ -1,7 +1,7 @@ -module XBattBar.Types (Options(..), Position(..), Orientation(..), XContext(..), ExtContext(..), ProgressBar(..), Label(..), XWidget(..)) where +module XBattBar.Types (Options(..), Position(..), Orientation(..), XContext(..), ExtContext(..), XWidget(..)) where -import Graphics.X11.Types -import Graphics.X11.Xlib.Event +import Graphics.X11.Types (expose, Window, EventType) +import Graphics.X11.Xlib.Event (XEventPtr) import Graphics.X11.Xlib.Font (FontStruct) import Graphics.X11.Xlib.Window (mapWindow) import Graphics.X11.Xlib.Extras (unmapWindow) @@ -63,22 +63,3 @@ handleWidgetEvent a ev et | et == expose = drawWidget a | otherwise = return () - --- | progress bar-like widget -data ProgressBar = ProgressBar { - pbXContext :: XContext, - pbExContext :: ExtContext, - colorBack :: Pixel, - colorBar :: Pixel, - progress :: Double, - orientation :: Orientation - } --- | multiline non-editable text widget with centered text -data Label = Label { - lXContext :: XContext, - lExContext :: ExtContext, - colorBG :: Pixel, - colorFont :: Pixel, - font :: FontStruct, - text :: [String] - } diff --git a/src/XBattBar/Widgets.hs b/src/XBattBar/Widgets.hs --- a/src/XBattBar/Widgets.hs +++ b/src/XBattBar/Widgets.hs @@ -1,52 +1,33 @@ -module XBattBar.Widgets (mkWidget, mkProgressBar, mkLabel) where +module XBattBar.Widgets (ProgressBar(colorBack, colorBar, progress), mkProgressBar, + Label(text), mkLabel) where -import Data.Word -import Data.Bits -import Control.Monad -import Graphics.X11.Types +import Graphics.X11.Types (EventMask, cWOverrideRedirect) import Graphics.X11.Xlib.Types hiding (Position) -import Graphics.X11.Xlib.Display -import Graphics.X11.Xlib.Window -import Graphics.X11.Xlib.Event -import Graphics.X11.Xlib.Misc -import Graphics.X11.Xlib.Context -import Graphics.X11.Xlib.Color -import Graphics.X11.Xlib.Font +import Graphics.X11.Xlib.Display (blackPixel, whitePixel) +import Graphics.X11.Xlib.Window (createSimpleWindow) +import Graphics.X11.Xlib.Event (flush, selectInput) +import Graphics.X11.Xlib.Misc (fillRectangles, + drawString, + allocaSetWindowAttributes, + set_override_redirect) +import Graphics.X11.Xlib.Context (setForeground, createGC) +import Graphics.X11.Xlib.Font (FontStruct, + ascentFromFontStruct, + descentFromFontStruct, + textWidth, loadQueryFont) import Graphics.X11.Xlib.Extras (unmapWindow, changeWindowAttributes) import XBattBar.Types --- | wraps X11 window creation process -mkWidget :: XContext -> Rectangle -> EventMask -> Int -> (XContext -> ExtContext -> b) -> IO b -mkWidget ctx geom mask bw which = do - let attrmask = cWOverrideRedirect - borderWidth = fromIntegral bw - dpy' = dpy ctx - screen' = screen ctx - parent' = parent ctx - window <- createSimpleWindow dpy' parent' - (rect_x geom) - (rect_y geom) - (rect_width geom) - (rect_height geom) - borderWidth - (blackPixel dpy' screen') - (whitePixel dpy' screen') - allocaSetWindowAttributes $ \attrs -> do - set_override_redirect attrs True - changeWindowAttributes dpy' window cWOverrideRedirect attrs - gc <- createGC dpy' window - selectInput dpy' window mask - let ectx = ExtContext window geom gc - return $ which ctx ectx - -getIndicatorRect :: Orientation -> Double -> Rectangle -> Rectangle -getIndicatorRect pos perc rect = case pos of - Horizontal -> - rect { rect_x = p (rect_width rect) - fromIntegral (rect_width rect), rect_y = 0 } - Vertical -> - rect { rect_y = fromIntegral (rect_height rect) - p (rect_height rect), rect_x = 0 } - where p x = floor $ perc * fromIntegral x +-- | progress bar-like widget +data ProgressBar = ProgressBar { + pbXContext :: XContext, + pbExContext :: ExtContext, + colorBack :: Pixel, + colorBar :: Pixel, + progress :: Double, + orientation :: Orientation + } instance XWidget ProgressBar where xContext = pbXContext @@ -67,6 +48,14 @@ fillRectangles dpy' window' gc' [getIndicatorRect (orientation bar) (progress bar) geom'] flush dpy' +getIndicatorRect :: Orientation -> Double -> Rectangle -> Rectangle +getIndicatorRect pos perc rect = case pos of + Horizontal -> + rect { rect_x = p (rect_width rect) - fromIntegral (rect_width rect), rect_y = 0 } + Vertical -> + rect { rect_y = fromIntegral (rect_height rect) - p (rect_height rect), rect_x = 0 } + where p x = floor $ perc * fromIntegral x + -- | creates a progress bar-like widget mkProgressBar :: XContext -> Rectangle -> Pixel -> Pixel -> Orientation -> EventMask -> IO ProgressBar mkProgressBar xctx geom fg bg orientation mask = do @@ -75,6 +64,16 @@ f <- mkWidget xctx geom mask 0 ProgressBar return $ f fg bg 0.0 orientation +-- | multiline non-editable text widget with centered text +data Label = Label { + lXContext :: XContext, + lExContext :: ExtContext, + colorBG :: Pixel, + colorFont :: Pixel, + font :: FontStruct, + text :: [String] + } + instance XWidget Label where xContext = lXContext widgetContext = lExContext @@ -109,3 +108,26 @@ font <- loadQueryFont dpy' fontName f <- mkWidget xctx geom mask 2 Label return $ f bg fg font text + +-- | wraps X11 window creation process +mkWidget :: XContext -> Rectangle -> EventMask -> Int -> (XContext -> ExtContext -> b) -> IO b +mkWidget ctx geom mask bw which = do + let borderWidth = fromIntegral bw + dpy' = dpy ctx + screen' = screen ctx + parent' = parent ctx + window <- createSimpleWindow dpy' parent' + (rect_x geom) + (rect_y geom) + (rect_width geom) + (rect_height geom) + borderWidth + (blackPixel dpy' screen') + (whitePixel dpy' screen') + allocaSetWindowAttributes $ \attrs -> do + set_override_redirect attrs True + changeWindowAttributes dpy' window cWOverrideRedirect attrs + gc <- createGC dpy' window + selectInput dpy' window mask + let ectx = ExtContext window geom gc + return $ which ctx ectx diff --git a/xbattbar.cabal b/xbattbar.cabal --- a/xbattbar.cabal +++ b/xbattbar.cabal @@ -1,5 +1,5 @@ name: xbattbar -version: 0.1 +version: 0.2 synopsis: Simple battery indicator homepage: https://github.com/polachok/xbattbar license: MIT @@ -20,6 +20,5 @@ executable xbattbar main-is: Main.hs other-modules: XBattBar.Types, XBattBar.Core, XBattBar.Backend, XBattBar.Widgets - GHC-Options: -with-rtsopts=-V0 - build-depends: base < 5, X11, select, old-time + build-depends: base < 5, X11, select >= 0.4, old-time hs-source-dirs: src