xbattbar (empty) → 0.1
raw patch · 8 files changed
+488/−0 lines, 8 filesdep +X11dep +basedep +old-timesetup-changed
Dependencies added: X11, base, old-time, select
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- src/Main.hs +59/−0
- src/XBattBar/Backend.hs +32/−0
- src/XBattBar/Core.hs +154/−0
- src/XBattBar/Types.hs +84/−0
- src/XBattBar/Widgets.hs +111/−0
- xbattbar.cabal +25/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT/X Consortium License++(c) 2012 Alexander Polakov <plhk at sdf dot org>++Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense,+and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. ++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Main.hs view
@@ -0,0 +1,59 @@+module Main (main) where+import System.Environment+import System.Console.GetOpt++import Prelude hiding (Left, Right)+import XBattBar.Types+import XBattBar.Core (start)++defaultOptions :: Options+defaultOptions = Options {+ onTop = False,+ thickness = 2,+ interval = 5,+ chargeColorAC = "green",+ dischargeColorAC = "olive drab",+ chargeColorBat = "blue",+ dischargeColorBat = "red",+ position = Bottom+ }++options :: [ OptDescr (Options -> Options) ]+options =+ [ Option "a" [] (NoArg (\opts -> opts { onTop = True }))+ "Always on top",+ Option "t" [] (ReqArg (\x s -> s { thickness = read x }) "PX")+ "Thickness",+ Option "p" [] (ReqArg (\x s -> s { interval = read x }) "PX")+ "Polling interval",+ Option "I" [] (ReqArg (\x s -> s { chargeColorAC = x }) "PX")+ "Charge color when on AC",+ Option "O" [] (ReqArg (\x s -> s { dischargeColorAC = x }) "PX")+ "Discharge color when on AC",+ Option "o" [] (ReqArg (\x s -> s { dischargeColorBat = x }) "PX")+ "Charge color when on battery",+ Option "i" [] (ReqArg (\x s -> s { chargeColorBat = x }) "PX")+ "Discharge color when on battery",+ Option "h" [] (NoArg (usage))+ "Print help message"+ ]++nonoptions :: Options -> [String] -> Options+nonoptions opts [] = opts+nonoptions opts ["top"] = opts { position = Top }+nonoptions opts ["bottom"] = opts { position = Bottom }+nonoptions opts ["left"] = opts { position = Left }+nonoptions opts ["right"] = opts { position = Right }+nonoptions _ _ = usage++usage = error $ "usage: xbattbar [-a] [-h|v] [-p sec] [-t thickness] " +++ "[-I color] [-O color] [-i color] [-o color] " +++ "[ top | bottom | left | right ]"++main = do+ args <- getArgs+ + let (actions, nonOptions, errors) = getOpt RequireOrder options args++ let opts = foldl (flip id) defaultOptions actions+ start $ nonoptions opts nonOptions
+ src/XBattBar/Backend.hs view
@@ -0,0 +1,32 @@+module XBattBar.Backend (getCharge, getPower, Power(..)) where+import System.Environment++data Power = AC | Battery+ deriving (Show)++-- | retrieves battery charge+getCharge :: IO Double+getCharge = getChargeLinux++-- | retrieves power status+getPower :: IO Power+getPower = getPowerLinux++-- | get charge from ACPI on linux+getChargeLinux :: IO Double+getChargeLinux = do+ let path = "/sys/bus/acpi/drivers/battery/PNP0C0A:00/power_supply/BAT0/"+ fullS <- readFile $ path++"energy_full"+ nowS <- readFile $ path++"energy_now"+ let f = read fullS+ let n = read nowS+ return (n / f)++-- | get power state from ACPI on linux+getPowerLinux :: IO Power+getPowerLinux = do+ let path = "/sys/bus/acpi/drivers/ac/ACPI0003:00/power_supply/AC/online"+ s <- readFile path+ return $ case (read s) of + 0 -> Battery+ 1 -> AC
+ src/XBattBar/Core.hs view
@@ -0,0 +1,154 @@+module XBattBar.Core (start) where+import Prelude hiding (Left, Right)+import Data.Word+import Data.Bits+import Control.Monad+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.Event+import Graphics.X11.Xlib.Misc+import Graphics.X11.Xlib.Context+import Graphics.X11.Xlib.Color+import Graphics.X11.Xlib.Extras (unmapWindow)+import System.Posix.IO.Select+import System.Posix.Types+import System.Time (getClockTime, ClockTime)++import XBattBar.Types+import XBattBar.Backend+import XBattBar.Widgets++data XBattBar = XBattBar {+ options :: Options,+ bar :: ProgressBar,+ popup :: Label,+ colorAC :: (Pixel, Pixel),+ colorBat :: (Pixel, Pixel)+ }++-- | retrieve screen geometry+getScreenRect :: XContext -> Rectangle+getScreenRect ctx = Rectangle 0 0 sw sh+ where dpy' = dpy ctx+ screen' = screen ctx+ sw = fromIntegral $ displayWidth dpy' screen'+ sh = fromIntegral $ displayHeight dpy' screen'++-- | transform screen geometry into bar geometry+getBarRect :: Position -> Dimension -> Rectangle -> Rectangle+getBarRect pos th rect = case pos of+ Top -> rect { rect_height = th }+ Bottom -> getBarRect Top th $ rect { rect_y = fromIntegral $ rect_height rect - th }+ Left -> rect { rect_width = th }+ Right -> getBarRect Left th $ rect { rect_x = fromIntegral $ rect_width rect - th }++-- | transform screen geometry into popup window geometry+getPopupRect :: Rectangle -> Rectangle+getPopupRect scr = Rectangle x y w h+ where x = fromIntegral $ rect_width scr `div` 2 - w `div` 2+ y = fromIntegral $ rect_height scr `div` 2 - h `div` 2+ w = 240+ h = 60++-- | get pixels from color names+getColors :: XContext -> Options -> IO ((Pixel, Pixel), (Pixel, Pixel))+getColors ctx opts = do+ let dpy' = dpy ctx+ screen' = screen ctx+ allocColor = allocNamedColor dpy' (defaultColormap dpy' screen')+ allocPixel f = (allocColor $ f opts) >>= (\(c,_) -> return $ color_pixel c)+ [a1, a2, b1, b2] <- mapM allocPixel [chargeColorAC, dischargeColorAC, chargeColorBat, dischargeColorBat]+ return ((a1, a2), (b1, b2))++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+ let orientation' x | x == Top || x == Bottom = Horizontal+ | otherwise = Vertical+ 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)++-- | dispatch X11 events to widgets+handleEvents :: XBattBar -> Double -> Power -> IO ()+handleEvents xbb charge state = do+ let bar' = bar xbb+ popup' = popup xbb+ dpy' = dpy $ xContext bar'+ barWin = window $ widgetContext bar'+ popupWin = window $ widgetContext popup'+ 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'+ | 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++selectWrapper fd int eventH timeoutH = do+ n <- select [fd] [] [] (Time int 0)+ case n of + -1 -> error "select() error"+ 0 -> return timeoutH+ _ -> return eventH++-- | necessary transformations on state change+applyState :: XBattBar -> Double -> Power -> ClockTime -> XBattBar+applyState xbb charge state time =+ let bar' = bar xbb+ popup' = popup xbb+ (af, ab) = colorAC xbb+ (bf, bb) = colorBat xbb+ text' = [(show state)++"-powered: battery level is "++(show $ floor $ 100 * charge)++"%", show time]+ in case state of+ AC -> xbb { bar =+ bar' { colorBack = ab,+ colorBar = af,+ progress = charge },+ popup = popup' { text = text' }+ }+ Battery -> xbb { bar =+ bar' { colorBack = bb,+ colorBar = bf,+ progress = charge },+ popup = popup' { text = text' }+ }++-- | main loop+run :: XBattBar -> IO ()+run xbb = do+ let bar' = bar xbb+ popup' = popup xbb+ dpy' = dpy $ xContext bar'+ int = interval $ options xbb+ displayWidget bar'+ sync dpy' False+ let fd = Fd $ connectionNumber dpy'+ forever $ do+ c <- getCharge+ s <- getPower+ t <- getClockTime+ let xbb' = applyState xbb c s t+ drawWidget $ bar xbb'+ selectWrapper fd int handleEvents handleTimeout >>= (\h -> h xbb' c s)
+ src/XBattBar/Types.hs view
@@ -0,0 +1,84 @@+module XBattBar.Types (Options(..), Position(..), Orientation(..), XContext(..), ExtContext(..), ProgressBar(..), Label(..), XWidget(..)) where++import Graphics.X11.Types+import Graphics.X11.Xlib.Event+import Graphics.X11.Xlib.Font (FontStruct)+import Graphics.X11.Xlib.Window (mapWindow)+import Graphics.X11.Xlib.Extras (unmapWindow)+import Graphics.X11.Xlib.Types hiding (Position)++data Position = Top | Bottom | Left | Right+ deriving (Eq, Show)++-- | progress bar vartiants+data Orientation = Vertical | Horizontal++-- | command-line options map to this+data Options = Options {+ onTop :: Bool,+ thickness :: Int,+ interval :: Int,+ chargeColorAC :: String,+ dischargeColorAC :: String,+ chargeColorBat :: String,+ dischargeColorBat :: String,+ position :: Position+ } deriving (Show)++-- | basic X11 context+data XContext = XContext {+ dpy :: Display,+ screen :: ScreenNumber,+ parent :: Window+ }+-- | extended X11 context+data ExtContext = ExtContext {+ window :: Window,+ geom :: Rectangle,+ gc :: GC+ }++-- | XWidget is an X11 window with some context attached+class XWidget a where+ xContext :: a -> XContext+ widgetContext :: a -> ExtContext+ -- | makes the actual widget drawing+ drawWidget :: a -> IO ()+ -- | display widget on screen+ displayWidget :: a -> IO ()+ -- | hide widget+ hideWidget :: a -> IO ()+ -- | handle X11 events for the widget+ handleWidgetEvent :: a -> XEventPtr -> EventType -> IO ()++ displayWidget a = do+ let window' = window $ widgetContext a+ dpy' = dpy $ xContext a+ mapWindow dpy' window'++ hideWidget a = do+ let window' = window $ widgetContext a+ dpy' = dpy $ xContext a+ unmapWindow dpy' window'++ 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]+ }
+ src/XBattBar/Widgets.hs view
@@ -0,0 +1,111 @@+module XBattBar.Widgets (mkWidget, mkProgressBar, mkLabel) where++import Data.Word+import Data.Bits+import Control.Monad+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.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.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++instance XWidget ProgressBar+ where xContext = pbXContext+ widgetContext = pbExContext+ drawWidget bar = do+ let ctx' = xContext bar+ ectx' = widgetContext bar+ dpy' = dpy ctx'+ screen' = screen ctx'+ window' = window ectx'+ gc' = gc ectx'+ geom' = geom ectx'+ fg = colorBar bar+ bg = colorBack bar+ setForeground dpy' gc' bg+ fillRectangles dpy' window' gc' [geom']+ setForeground dpy' gc' fg+ fillRectangles dpy' window' gc' [getIndicatorRect (orientation bar) (progress bar) geom']+ flush dpy'++-- | creates a progress bar-like widget+mkProgressBar :: XContext -> Rectangle -> Pixel -> Pixel -> Orientation -> EventMask -> IO ProgressBar+mkProgressBar xctx geom fg bg orientation mask = do+ let dpy' = dpy xctx+ screen' = screen xctx+ f <- mkWidget xctx geom mask 0 ProgressBar+ return $ f fg bg 0.0 orientation++instance XWidget Label+ where xContext = lXContext+ widgetContext = lExContext+ drawWidget label = do+ let ctx' = xContext label+ ectx' = widgetContext label+ dpy' = dpy ctx'+ screen' = screen ctx'+ window' = window ectx'+ gc' = gc ectx'+ geom' = geom ectx'+ fg = colorFont label+ bg = colorBG label+ text' = text label+ font' = font label+ h = ascentFromFontStruct font' + descentFromFontStruct font'+ tw = fromIntegral . textWidth font'+ tx t = fromIntegral $ rect_width geom' `div` 2 - (tw t) `div` 2+ ty = fromIntegral $ rect_height geom' `div` 2+ setForeground dpy' gc' bg+ fillRectangles dpy' window' gc' [geom']+ setForeground dpy' gc' fg+ mapM (\(s,y) -> drawString dpy' window' gc' (tx s) y s) $ zip text' [ty, (ty+h)..]+ flush dpy'+ handleWidgetEvent label ev et = drawWidget label++-- | creates a multiline non-editable text widget+mkLabel :: XContext -> Rectangle -> Pixel -> Pixel -> String -> [String] -> EventMask -> IO Label+mkLabel xctx geom fg bg fontName text mask = do+ let dpy' = dpy xctx+ screen' = screen xctx+ font <- loadQueryFont dpy' fontName+ f <- mkWidget xctx geom mask 2 Label+ return $ f bg fg font text
+ xbattbar.cabal view
@@ -0,0 +1,25 @@+name: xbattbar+version: 0.1+synopsis: Simple battery indicator+homepage: https://github.com/polachok/xbattbar+license: MIT+license-file: LICENSE+author: Alexander Polakov+maintainer: plhk@sdf.org+-- copyright:+category: Graphics+build-type: Simple+cabal-version: >=1.4+description: XBattBar is a simple battery indicator for X11/Linux.+ It draws a vertical or horizontal bar on your screen,+ which displays current power and charging status with+ color lines. A popup window appears when mouse cursor+ enters the indicator area. It shows current AC status,+ battery level and time.++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+ hs-source-dirs: src