summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2022-09-18 00:18:39 +0100
committerjao <jao@gnu.org>2022-09-18 00:18:39 +0100
commit1d801183a54d3d6bf734d485ace744cdf78f3a77 (patch)
tree08c490887755dc8fc566d9e570d75361421dd868
parent2e9bc4187f0094d202fc11aa05f0637edcabf9bb (diff)
downloadxmobar-1d801183a54d3d6bf734d485ace744cdf78f3a77.tar.gz
xmobar-1d801183a54d3d6bf734d485ace744cdf78f3a77.tar.bz2
qualified imports
-rw-r--r--src/Xmobar/Config/Types.hs20
-rw-r--r--src/Xmobar/X11/Boxes.hs73
-rw-r--r--src/Xmobar/X11/CairoDraw.hs208
-rw-r--r--src/Xmobar/X11/Loop.hs211
4 files changed, 264 insertions, 248 deletions
diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs
index a448d5d..4959aa1 100644
--- a/src/Xmobar/Config/Types.hs
+++ b/src/Xmobar/Config/Types.hs
@@ -15,12 +15,13 @@
module Xmobar.Config.Types
( Config (..)
, XPosition (..), Align (..), Border (..), TextOutputFormat (..)
- , FontIndex, SignalChan (..)
+ , FontIndex
+ , SignalChan (..)
) where
import qualified Control.Concurrent.STM as STM
-import Xmobar.Run.Runnable (Runnable(..))
-import Xmobar.System.Signal (SignalType)
+import qualified Xmobar.Run.Runnable as R
+import qualified Xmobar.System.Signal as S
-- $config
-- Configuration data type
@@ -35,7 +36,8 @@ data Config =
, fgColor :: String -- ^ Default font color
, position :: XPosition -- ^ Top Bottom or Static
, textOutput :: Bool -- ^ Write data to stdout instead of X
- , textOutputFormat :: TextOutputFormat -- ^ Which color format to use for stdout: Ansi or Pango
+ , textOutputFormat :: TextOutputFormat
+ -- ^ Which color format to use for stdout: Ansi or Pango
, textOffset :: Int -- ^ Offset from top of window for text
, textOffsets :: [Int] -- ^ List of offsets for additionalFonts
, iconOffset :: Int -- ^ Offset from top of window for icons
@@ -57,8 +59,8 @@ data Config =
, persistent :: Bool -- ^ Whether automatic hiding should
-- be enabled or disabled
, iconRoot :: FilePath -- ^ Root folder for icons
- , commands :: [Runnable] -- ^ For setting the command,
- -- the command arguments
+ , commands :: [R.Runnable] -- ^ For setting the command,
+ -- the command arguments
-- and refresh rate for the programs
-- to run (optional)
, sepChar :: String -- ^ The character to be used for indicating
@@ -68,7 +70,7 @@ data Config =
-- right text alignment
, template :: String -- ^ The output template
, verbose :: Bool -- ^ Emit additional debug messages
- , signal :: SignalChan -- ^ The signal channel to send signals to xmobar
+ , signal :: SignalChan -- ^ Channel to send signals to xmobar
} deriving (Read, Show)
data XPosition = Top
@@ -98,9 +100,9 @@ data Border = NoBorder
data TextOutputFormat = Plain | Ansi | Pango | Swaybar deriving (Read, Show, Eq)
-type FontIndex = Int
+type FontIndex = Int
-newtype SignalChan = SignalChan { unSignalChan :: Maybe (STM.TMVar SignalType) }
+newtype SignalChan = SignalChan {unSignalChan :: Maybe (STM.TMVar S.SignalType)}
instance Read SignalChan where
readsPrec _ _ = fail "SignalChan is not readable from a String"
diff --git a/src/Xmobar/X11/Boxes.hs b/src/Xmobar/X11/Boxes.hs
index 87a081f..4ea7144 100644
--- a/src/Xmobar/X11/Boxes.hs
+++ b/src/Xmobar/X11/Boxes.hs
@@ -7,51 +7,62 @@
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: unportable
---Start date: Fri Sep 16, 2022 04:01
+-- Start date: Fri Sep 16, 2022 04:01
--
-- Borders and boxes
--
------------------------------------------------------------------------------
-module Xmobar.X11.Boxes (boxLines, borderRect) where
+module Xmobar.X11.Boxes (Line, boxLines, BoxRect, borderRect) where
-import Xmobar.Run.Parsers
-import Xmobar.Config.Types
+import qualified Xmobar.Config.Types as T
+import qualified Xmobar.Run.Parsers as P
+
+type Line = (Double, Double, Double, Double)
+type BoxRect = (Double, Double, Double, Double)
-- | Computes the coordinates of a list of lines representing a Box.
-- The Box is to be positioned between x0 and x1, with height ht, and drawn
-- with line width lw. The returned lists are coordinates of the beginning
-- and end of each line.
-boxLines :: Box -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
-boxLines (Box bd offset lw _ margins) ht x0 x1 =
+boxLines :: P.Box -> Double -> Double -> Double -> [Line]
+boxLines (P.Box bd offset lw _ margins) ht x0 x1 =
case bd of
- BBTop -> [rtop]; BBBottom -> [rbot]; BBVBoth -> [rtop, rbot]
- BBLeft -> [rleft]; BBRight -> [rright]; BBHBoth -> [rleft, rright]
- BBFull -> [rtop, rbot, rleft, rright]
- where (BoxMargins top right bot left) = margins
- (BoxOffset align m) = offset
- ma = fromIntegral m
- (p0, p1) = case align of L -> (0, -ma); C -> (ma, -ma); R -> (ma, 0)
- lc = fromIntegral lw / 2
- [mt, mr, mb, ml] = map fromIntegral [top, right, bot, left]
- xmin = x0 - ml - lc
- xmax = x1 + mr + lc
- ymin = mt + lc
- ymax = ht - mb - lc
- rtop = (xmin + p0, ymin, xmax + p1, ymin)
- rbot = (xmin + p0, ymax, xmax + p1, ymax)
- rleft = (xmin, ymin + p0, xmin, ymax + p1)
- rright = (xmax, ymin + p0, xmax, ymax + p1)
+ P.BBTop -> [rtop]
+ P.BBBottom -> [rbot]
+ P.BBVBoth -> [rtop, rbot]
+ P.BBLeft -> [rleft]
+ P.BBRight -> [rright]
+ P.BBHBoth -> [rleft, rright]
+ P.BBFull -> [rtop, rbot, rleft, rright]
+ where
+ (P.BoxMargins top right bot left) = margins
+ (P.BoxOffset align m) = offset
+ ma = fromIntegral m
+ (p0, p1) = case align of
+ T.L -> (0, -ma)
+ T.C -> (ma, -ma)
+ T.R -> (ma, 0)
+ lc = fromIntegral lw / 2
+ [mt, mr, mb, ml] = map fromIntegral [top, right, bot, left]
+ xmin = x0 - ml - lc
+ xmax = x1 + mr + lc
+ ymin = mt + lc
+ ymax = ht - mb - lc
+ rtop = (xmin + p0, ymin, xmax + p1, ymin)
+ rbot = (xmin + p0, ymax, xmax + p1, ymax)
+ rleft = (xmin, ymin + p0, xmin, ymax + p1)
+ rright = (xmax, ymin + p0, xmax, ymax + p1)
-- | Computes the rectangle (x, y, width, height) for the given Border.
-borderRect :: Border -> Double -> Double -> (Double, Double, Double, Double)
+borderRect :: T.Border -> Double -> Double -> BoxRect
borderRect bdr w h =
case bdr of
- TopB -> (0, 0, w - 1, 0)
- BottomB -> (0, h - 1, w - 1, 0)
- FullB -> (0, 0, w - 1, h - 1)
- TopBM m -> (0, fi m, w - 1, 0)
- BottomBM m -> (0, h - fi m, w - 1, 0)
- FullBM m -> (fi m, fi m, w - 2 * fi m, h - 2 * fi m)
- NoBorder -> (-1, -1, -1, -1)
+ T.TopB -> (0, 0, w - 1, 0)
+ T.BottomB -> (0, h - 1, w - 1, 0)
+ T.FullB -> (0, 0, w - 1, h - 1)
+ T.TopBM m -> (0, fi m, w - 1, 0)
+ T.BottomBM m -> (0, h - fi m, w - 1, 0)
+ T.FullBM m -> (fi m, fi m, w - 2 * fi m, h - 2 * fi m)
+ T.NoBorder -> (-1, -1, -1, -1)
where fi = fromIntegral
diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs
index b7ecd34..0007f3e 100644
--- a/src/Xmobar/X11/CairoDraw.hs
+++ b/src/Xmobar/X11/CairoDraw.hs
@@ -17,76 +17,77 @@
module Xmobar.X11.CairoDraw (drawInPixmap) where
-import Prelude hiding (lookup)
-
-import Data.Map (lookup)
+import qualified Data.Map as M
import qualified Data.Colour.SRGB as SRGB
import qualified Data.Colour.Names as CNames
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-
-import Graphics.X11.Xlib hiding (Segment, drawSegments)
-import Graphics.Rendering.Cairo.Types
-import qualified Graphics.Rendering.Cairo as C
-import qualified Graphics.Rendering.Pango as P
-
-import Xmobar.Run.Parsers (Segment
- , Widget(..)
- , Box (..)
- , TextRenderInfo (..)
- , colorComponents)
-import Xmobar.Config.Types
-import Xmobar.Config.Parse (indexedFont, indexedOffset)
-import Xmobar.Text.Pango (fixXft)
-import Xmobar.X11.Types
-import Xmobar.X11.Boxes (boxLines, borderRect)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad (foldM, when)
+import Control.Monad.Reader (ask)
+
+import qualified Graphics.X11.Xlib as X11
+import qualified Graphics.Rendering.Cairo as Cairo
+import qualified Graphics.Rendering.Pango as Pango
+
+import Graphics.Rendering.Cairo.Types(Surface)
+
+import qualified Xmobar.Config.Types as C
+import qualified Xmobar.Config.Parse as ConfigParse
+import qualified Xmobar.Run.Parsers as P
+import qualified Xmobar.Text.Pango as TextPango
+
+import qualified Xmobar.X11.Boxes as Boxes
import qualified Xmobar.X11.Bitmap as B
+import qualified Xmobar.X11.Types as X
+import Xmobar.X11.CairoSurface (withXlibSurface)
+
#ifdef XRENDER
-import Xmobar.X11.XRender (drawBackground)
+import qualified Xmobar.X11.XRender as XRender
#endif
-import Xmobar.X11.CairoSurface
-type Renderinfo = (Segment, Surface -> Double -> Double -> IO (), Double)
+type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double)
type BitmapDrawer = Double -> Double -> String -> IO ()
-type Actions = [ActionPos]
+type Actions = [X.ActionPos]
data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer
, dcBitmapLookup :: String -> Maybe B.Bitmap
- , dcConfig :: Config
+ , dcConfig :: C.Config
, dcWidth :: Double
, dcHeight :: Double
- , dcSegments :: [[Segment]]
+ , dcSegments :: [[P.Segment]]
}
-drawInPixmap :: GC -> Pixmap -> [[Segment]] -> X Actions
+drawInPixmap :: X11.GC -> X11.Pixmap -> [[P.Segment]] -> X.X Actions
drawInPixmap gc p s = do
xconf <- ask
- let disp = display xconf
- vis = defaultVisualOfScreen (defaultScreenOfDisplay disp)
- (Rectangle _ _ w h) = rect xconf
+ let disp = X.display xconf
+ vis = X11.defaultVisualOfScreen (X11.defaultScreenOfDisplay disp)
+ (X11.Rectangle _ _ w h) = X.rect xconf
dw = fromIntegral w
dh = fromIntegral h
- conf = config xconf
+ conf = X.config xconf
dc = DC (drawXBitmap xconf gc p) (lookupXBitmap xconf) conf dw dh s
render = drawSegments dc
#ifdef XRENDER
- liftIO $ drawBackground disp p (bgColor conf) (alpha conf) (Rectangle 0 0 w h)
+ color = C.bgColor conf
+ alph = C.alpha conf
+ liftIO $ XRender.drawBackground disp p color alph (X11.Rectangle 0 0 w h)
#endif
liftIO $ withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render
-drawXBitmap :: XConf -> GC -> Pixmap -> BitmapDrawer
+drawXBitmap :: X.XConf -> X11.GC -> X11.Pixmap -> BitmapDrawer
drawXBitmap xconf gc p h v path = do
- let disp = display xconf
- conf = config xconf
- fc = fgColor conf
- bc = bgColor conf
- bm = lookupXBitmap xconf path
- liftIO $ maybe (return ()) (B.drawBitmap disp p gc fc bc (round h) (round v)) bm
+ let disp = X.display xconf
+ conf = X.config xconf
+ fc = C.fgColor conf
+ bc = C.bgColor conf
+ case lookupXBitmap xconf path of
+ Just bm -> liftIO $ B.drawBitmap disp p gc fc bc (round h) (round v) bm
+ Nothing -> return ()
-lookupXBitmap :: XConf -> String -> Maybe B.Bitmap
-lookupXBitmap xconf path = lookup path (iconCache xconf)
+lookupXBitmap :: X.XConf -> String -> Maybe B.Bitmap
+lookupXBitmap xconf path = M.lookup path (X.iconCache xconf)
readColourName :: String -> (SRGB.Colour Double, Double)
readColourName str =
@@ -97,113 +98,116 @@ readColourName str =
[(c,d)] -> (c, read ("0x" ++ d))
_ -> (CNames.white, 1.0)
-setSourceColor :: (SRGB.Colour Double, Double) -> C.Render ()
+setSourceColor :: (SRGB.Colour Double, Double) -> Cairo.Render ()
setSourceColor (colour, alph) =
- if alph < 1 then C.setSourceRGBA r g b alph else C.setSourceRGB r g b
+ if alph < 1 then Cairo.setSourceRGBA r g b alph else Cairo.setSourceRGB r g b
where rgb = SRGB.toSRGB colour
r = SRGB.channelRed rgb
g = SRGB.channelGreen rgb
b = SRGB.channelBlue rgb
-renderLines :: String -> Double -> [(Double, Double, Double, Double)] -> C.Render ()
+renderLines :: String -> Double -> [Boxes.Line] -> Cairo.Render ()
renderLines color wd lns = do
setSourceColor (readColourName color)
- C.setLineWidth wd
- mapM_ (\(x0, y0, x1, y1) -> C.moveTo x0 y0 >> C.lineTo x1 y1 >> C.stroke) lns
-
-segmentMarkup :: Config -> Segment -> String
-segmentMarkup conf (Text txt, info, idx, _actions) =
- let fnt = fixXft $ indexedFont conf idx
- (fg, bg) = colorComponents conf (tColorsString info)
- attrs = [P.FontDescr fnt, P.FontForeground fg]
- attrs' = if bg == bgColor conf then attrs else P.FontBackground bg:attrs
- in P.markSpan attrs' $ P.escapeMarkup txt
+ Cairo.setLineWidth wd
+ mapM_ (\(x0, y0, x1, y1) ->
+ Cairo.moveTo x0 y0 >> Cairo.lineTo x1 y1 >> Cairo.stroke) lns
+
+segmentMarkup :: C.Config -> P.Segment -> String
+segmentMarkup conf (P.Text txt, info, idx, _actions) =
+ let fnt = TextPango.fixXft $ ConfigParse.indexedFont conf idx
+ (fg, bg) = P.colorComponents conf (P.tColorsString info)
+ attrs = [Pango.FontDescr fnt, Pango.FontForeground fg]
+ attrs' = if bg == C.bgColor conf
+ then attrs
+ else Pango.FontBackground bg:attrs
+ in Pango.markSpan attrs' $ Pango.escapeMarkup txt
segmentMarkup _ _ = ""
-withRenderinfo :: P.PangoContext -> DrawContext -> Segment -> IO Renderinfo
-withRenderinfo ctx dctx seg@(Text _, inf, idx, a) = do
+withRenderinfo :: Pango.PangoContext -> DrawContext -> P.Segment -> IO Renderinfo
+withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = do
let conf = dcConfig dctx
- lyt <- P.layoutEmpty ctx
- mk <- P.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String
- (_, P.PangoRectangle o u w h) <- P.layoutGetExtents lyt
- let voff' = fromIntegral $ indexedOffset conf idx
+ lyt <- Pango.layoutEmpty ctx
+ mk <- Pango.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String
+ (_, Pango.PangoRectangle o u w h) <- Pango.layoutGetExtents lyt
+ let voff' = fromIntegral $ ConfigParse.indexedOffset conf idx
voff = voff' + (dcHeight dctx - h + u) / 2.0
wd = w - o
slyt s off mx = do
when (off + w > mx) $ do
- P.layoutSetEllipsize lyt P.EllipsizeEnd
- P.layoutSetWidth lyt (Just $ mx - off)
- C.renderWith s $ C.moveTo off voff >> P.showLayout lyt
- return ((Text mk, inf, idx, a), slyt, wd)
+ Pango.layoutSetEllipsize lyt Pango.EllipsizeEnd
+ Pango.layoutSetWidth lyt (Just $ mx - off)
+ Cairo.renderWith s $ Cairo.moveTo off voff >> Pango.showLayout lyt
+ return ((P.Text mk, inf, idx, a), slyt, wd)
-withRenderinfo _ _ seg@(Hspace w, _, _, _) =
+withRenderinfo _ _ seg@(P.Hspace w, _, _, _) =
return (seg, \_ _ _ -> return (), fromIntegral w)
-withRenderinfo _ dctx seg@(Icon p, _, _, _) = do
+withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do
let bm = dcBitmapLookup dctx p
wd = maybe 0 (fromIntegral . B.width) bm
- ioff = iconOffset (dcConfig dctx)
+ ioff = C.iconOffset (dcConfig dctx)
vpos = dcHeight dctx / 2 + fromIntegral ioff
draw _ off mx = when (off + wd <= mx) $ dcBitmapDrawer dctx off vpos p
return (seg, draw, wd)
-drawBox :: DrawContext -> Surface -> Double -> Double -> Box -> IO ()
-drawBox dctx surf x0 x1 box@(Box _ _ w color _) =
- C.renderWith surf $
- renderLines color (fromIntegral w) (boxLines box (dcHeight dctx) x0 x1)
+drawBox :: DrawContext -> Surface -> Double -> Double -> P.Box -> IO ()
+drawBox dctx surf x0 x1 box@(P.Box _ _ w color _) =
+ Cairo.renderWith surf $
+ renderLines color (fromIntegral w) (Boxes.boxLines box (dcHeight dctx) x0 x1)
drawSegmentBackground ::
- DrawContext -> Surface -> TextRenderInfo -> Double -> Double -> IO ()
+ DrawContext -> Surface -> P.TextRenderInfo -> Double -> Double -> IO ()
drawSegmentBackground dctx surf info x0 x1 =
- when (bg /= bgColor conf && (top >= 0 || bot >= 0)) $
- C.renderWith surf $ do
+ when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $
+ Cairo.renderWith surf $ do
setSourceColor (readColourName bg)
- C.rectangle x0 top (x1 - x0) (dcHeight dctx - bot - top)
- C.fillPreserve
+ Cairo.rectangle x0 top (x1 - x0) (dcHeight dctx - bot - top)
+ Cairo.fillPreserve
where conf = dcConfig dctx
- (_, bg) = colorComponents conf (tColorsString info)
- top = fromIntegral $ tBgTopOffset info
- bot = fromIntegral $ tBgBottomOffset info
+ (_, bg) = P.colorComponents conf (P.tColorsString info)
+ top = fromIntegral $ P.tBgTopOffset info
+ bot = fromIntegral $ P.tBgBottomOffset info
-type BoundedBoxes = [(Double, Double, [Box])]
-type SegAcc = (Double, Actions, BoundedBoxes)
+type BoundedBox = (Double, Double, [P.Box])
+type Acc = (Double, Actions, [BoundedBox])
-drawSegment :: DrawContext -> Surface -> Double -> SegAcc -> Renderinfo -> IO SegAcc
+drawSegment :: DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc
drawSegment dctx surface maxoff (off, acts, boxs) (segment, render, lwidth) = do
let end = min maxoff (off + lwidth)
(_, info, _, a) = segment
acts' = case a of Just as -> (as, round off, round end):acts; _ -> acts
- bs = tBoxes info
+ bs = P.tBoxes info
boxs' = if null bs then boxs else (off, end, bs):boxs
drawSegmentBackground dctx surface info off end
render surface off maxoff
return (off + lwidth, acts', boxs')
-renderOuterBorder :: Config -> Double -> Double -> C.Render ()
+renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render ()
renderOuterBorder conf mw mh = do
- let (x0, y0, w, h) = borderRect (border conf) mw mh
- setSourceColor (readColourName (borderColor conf))
- C.setLineWidth (fromIntegral (borderWidth conf))
- C.rectangle x0 y0 w h
- C.stroke
+ let (x0, y0, w, h) = Boxes.borderRect (C.border conf) mw mh
+ setSourceColor (readColourName (C.borderColor conf))
+ Cairo.setLineWidth (fromIntegral (C.borderWidth conf))
+ Cairo.rectangle x0 y0 w h
+ Cairo.stroke
-drawBorder :: Config -> Double -> Double -> Surface -> IO ()
+drawBorder :: C.Config -> Double -> Double -> Surface -> IO ()
drawBorder conf w h surf =
- case border conf of
- NoBorder -> return ()
- _ -> C.renderWith surf (renderOuterBorder conf w h)
+ case C.border conf of
+ C.NoBorder -> return ()
+ _ -> Cairo.renderWith surf (renderOuterBorder conf w h)
-drawBoxes' :: DrawContext -> Surface -> (Double, Double, [Box]) -> IO ()
-drawBoxes' dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs
+drawBBox :: DrawContext -> Surface -> BoundedBox -> IO ()
+drawBBox dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs
-drawBoxes :: DrawContext -> Surface -> BoundedBoxes -> IO ()
+drawBoxes :: DrawContext -> Surface -> [BoundedBox] -> IO ()
drawBoxes dctx surf ((from, to, b):(from', to', b'):bxs) =
if to < from' || b /= b'
- then do drawBoxes' dctx surf (from, to, b)
+ then do drawBBox dctx surf (from, to, b)
drawBoxes dctx surf $ (from', to', b'):bxs
else drawBoxes dctx surf $ (from, to', b'):bxs
-drawBoxes dctx surf [bi] = drawBoxes' dctx surf bi
+drawBoxes dctx surf [bi] = drawBBox dctx surf bi
drawBoxes _ _ [] = return ()
@@ -211,7 +215,7 @@ drawBoxes _ _ [] = return ()
drawCairoBackground :: DrawContext -> Surface -> IO ()
drawCairoBackground dctx surf = do
let (c, _) = readColourName (bgColor (dcConfig dctx))
- C.renderWith surf $ setSourceColor (c, 1.0) >> C.paint
+ Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint
#endif
drawSegments :: DrawContext -> Surface -> IO Actions
@@ -221,7 +225,7 @@ drawSegments dctx surf = do
dw = dcWidth dctx
conf = dcConfig dctx
sWidth = foldl (\a (_,_,w) -> a + w) 0
- ctx <- P.cairoCreateContext Nothing
+ ctx <- Pango.cairoCreateContext Nothing
llyts <- mapM (withRenderinfo ctx dctx) left
rlyts <- mapM (withRenderinfo ctx dctx) right
clyts <- mapM (withRenderinfo ctx dctx) center
@@ -237,5 +241,5 @@ drawSegments dctx surf = do
(_, as', bx') <- foldM (drawSegment dctx surf cmax) (cstart, as, bx) clyts
(_, as'', bx'') <- foldM (drawSegment dctx surf dw) (rstart, as', bx') rlyts
drawBoxes dctx surf (reverse bx'')
- when (borderWidth conf > 0) (drawBorder conf dw dh surf)
+ when (C.borderWidth conf > 0) (drawBorder conf dw dh surf)
return as''
diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs
index aeaf38a..3c1a25c 100644
--- a/src/Xmobar/X11/Loop.hs
+++ b/src/Xmobar/X11/Loop.hs
@@ -19,159 +19,158 @@
module Xmobar.X11.Loop (x11Loop) where
import Prelude hiding (lookup)
-import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment, Button)
-import Graphics.X11.Xlib.Extras
-import Graphics.X11.Xinerama
-import Graphics.X11.Xrandr
-import Control.Monad.Reader
-import Control.Concurrent
-import Control.Concurrent.STM
+import Control.Concurrent as Concurrent
+import Control.Concurrent.STM as STM
+import Control.Monad.Reader as MR
-import Data.Bits
+import Data.Bits (Bits((.|.)))
import qualified Data.Map as Map
-import Data.List.NonEmpty (NonEmpty(..))
+import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NE
-import Xmobar.System.Signal
-import Xmobar.Config.Types ( persistent
- , alpha
- , font
- , additionalFonts
- , position
- , iconRoot
- , Config
- , XPosition(..))
-
-import Xmobar.Run.Actions
-import Xmobar.Run.Parsers
-import Xmobar.X11.Window
-import Xmobar.X11.Text
-import Xmobar.X11.Draw
-import Xmobar.X11.Bitmap as Bitmap
-import Xmobar.X11.Types
-import Xmobar.System.Utils (forkThread)
-
-import Xmobar.Run.Loop (loop)
+import qualified Graphics.X11.Xlib as X11
+import qualified Graphics.X11.Xlib.Extras as X11x
+import qualified Graphics.X11.Xinerama as Xinerama
+import qualified Graphics.X11.Xrandr as Xrandr
+
+import qualified Xmobar.Config.Types as C
+
+import qualified Xmobar.Run.Actions as A
+import qualified Xmobar.Run.Loop as L
+import qualified Xmobar.Run.Parsers as P
+
+import qualified Xmobar.System.Utils as U
+import qualified Xmobar.System.Signal as S
+
+import qualified Xmobar.X11.Types as T
+import qualified Xmobar.X11.Text as Text
+import qualified Xmobar.X11.Draw as Draw
+import qualified Xmobar.X11.Bitmap as Bitmap
+import qualified Xmobar.X11.Window as W
#ifndef THREADED_RUNTIME
-import Xmobar.X11.Events(nextEvent')
+import qualified Xmobar.X11.Events as E
#endif
-runX :: XConf -> X a -> IO a
-runX xc f = runReaderT f xc
+runX :: T.XConf -> T.X a -> IO a
+runX xc f = MR.runReaderT f xc
--- | Starts the main event loop and threads
-x11Loop :: Config -> IO ()
+-- | Starts the main event loop thread
+x11Loop :: C.Config -> IO ()
x11Loop conf = do
- initThreads
- d <- openDisplay ""
- fs <- initFont d (font conf)
- fl <- mapM (initFont d) (additionalFonts conf)
- (r,w) <- createWin d fs conf
- loop conf (startLoop (XConf d r w (fs :| fl) Map.empty conf))
-
-startLoop :: XConf -> TMVar SignalType -> TVar [String] -> IO ()
-startLoop xcfg@(XConf _ _ w _ _ _) sig tv = do
- forkThread "X event handler" (x11EventLoop w sig)
- signalLoop xcfg [] sig tv
+ X11.initThreads
+ d <- X11.openDisplay ""
+ fs <- Text.initFont d (C.font conf)
+ fl <- mapM (Text.initFont d) (C.additionalFonts conf)
+ (r,w) <- W.createWin d fs conf
+ L.loop conf (startLoop (T.XConf d r w (fs :| fl) Map.empty conf))
+
+startLoop :: T.XConf -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO ()
+startLoop xcfg sig tv = do
+ U.forkThread "X event handler" (eventLoop (T.display xcfg) (T.window xcfg) sig)
+ signalLoop xcfg [] sig tv
-- | Translates X11 events received by w to signals handled by signalLoop
-x11EventLoop :: Window -> TMVar SignalType -> IO ()
-x11EventLoop w signal =
- allocaXEvent $ \e -> do
- dpy <- openDisplay ""
- xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask
- selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)
-
- forever $ do
+eventLoop :: X11.Display -> X11.Window -> STM.TMVar S.SignalType -> IO ()
+eventLoop dpy w signalv =
+ X11.allocaXEvent $ \e -> do
+ let root = X11.defaultRootWindow dpy
+ m = X11.exposureMask .|. X11.structureNotifyMask .|. X11.buttonPressMask
+ Xrandr.xrrSelectInput dpy root X11.rrScreenChangeNotifyMask
+ X11.selectInput dpy w m
+
+ MR.forever $ do
#ifdef THREADED_RUNTIME
- nextEvent dpy e
+ X11.nextEvent dpy e
#else
- nextEvent' dpy e
+ E.nextEvent' dpy e
#endif
- ev <- getEvent e
+ ev <- X11x.getEvent e
+ let send s = STM.atomically (STM.putTMVar signalv s)
case ev of
- ConfigureEvent {} -> atomically $ putTMVar signal Reposition
- ExposeEvent {} -> atomically $ putTMVar signal Wakeup
- RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition
- ButtonEvent {} -> atomically $
- putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))
+ X11x.ConfigureEvent {} -> send S.Reposition
+ X11x.RRScreenChangeNotifyEvent {} -> send S.Reposition
+ X11x.ExposeEvent {} -> send S.Wakeup
+ X11x.ButtonEvent {} -> send (S.Action b p)
+ where (b, p) = (X11x.ev_button ev, fromIntegral $ X11x.ev_x ev)
_ -> return ()
-- | Continuously wait for a signal from a thread or an interrupt handler.
-- The list of actions provides the positions of clickable rectangles,
-- and there is a mutable variable for received signals and the list
-- of strings updated by running monitors.
-signalLoop :: XConf
- -> [([Action], Position, Position)]
- -> TMVar SignalType
- -> TVar [String]
+signalLoop :: T.XConf
+ -> [([A.Action], X11.Position, X11.Position)]
+ -> STM.TMVar S.SignalType
+ -> STM.TVar [String]
-> IO ()
-signalLoop xc@(XConf d r w fs is cfg) actions signal strs = do
- typ <- atomically $ takeTMVar signal
+signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do
+ typ <- STM.atomically $ STM.takeTMVar signalv
case typ of
- Wakeup -> wakeup
- Action button x -> runActions actions button x >> loopOn
- Reposition -> reposWindow cfg
- ChangeScreen -> updateConfigPosition d cfg >>= reposWindow
- Hide t -> hiderev t Hide hideWindow
- Reveal t -> hiderev t Reveal (showWindow r cfg)
- Toggle t -> toggle t
- TogglePersistent -> updateCfg $ cfg {persistent = not $ persistent cfg}
- SetAlpha a -> updateCfg $ cfg {alpha = a}
+ S.Wakeup -> wakeup
+ S.Action button x -> runActions actions button x >> loopOn
+ S.Reposition -> reposWindow cfg
+ S.ChangeScreen -> updateConfigPosition d cfg >>= reposWindow
+ S.Hide t -> hiderev t S.Hide W.hideWindow
+ S.Reveal t -> hiderev t S.Reveal (W.showWindow r cfg)
+ S.Toggle t -> toggle t
+ S.TogglePersistent -> updateCfg $ cfg {C.persistent = not $ C.persistent cfg}
+ S.SetAlpha a -> updateCfg $ cfg {C.alpha = a}
where
- loopOn' xc' = signalLoop xc' actions signal strs
+ loopOn' xc' = signalLoop xc' actions signalv strs
loopOn = loopOn' xc
- updateCfg cfg' = loopOn' (xc {config = cfg'})
+ updateCfg cfg' = loopOn' (xc {T.config = cfg'})
wakeup = do
segs <- parseSegments cfg strs
xc' <- updateIconCache xc segs
- actions' <- runX xc' $ drawInWin segs
- signalLoop xc' actions' signal strs
+ actions' <- runX xc' $ Draw.drawInWin segs
+ signalLoop xc' actions' signalv strs
hiderev t sign op
- | t == 0 = unless (persistent cfg) (op d w) >> loopOn
+ | t == 0 = MR.unless (C.persistent cfg) (op d w) >> loopOn
| otherwise = do
- void $ forkIO
- $ threadDelay (t*100*1000) >>
- atomically (putTMVar signal $ sign 0)
+ MR.void $ Concurrent.forkIO
+ $ Concurrent.threadDelay (t*100*1000) >>
+ STM.atomically (STM.putTMVar signalv $ sign 0)
loopOn
toggle t = do
- ismapped <- isMapped d w
- atomically (putTMVar signal $ if ismapped then Hide t else Reveal t)
- loopOn
+ ismapped <- W.isMapped d w
+ let s = if ismapped then S.Hide t else S.Reveal t
+ STM.atomically (STM.putTMVar signalv s)
+ loopOn
reposWindow rcfg = do
- r' <- repositionWin d w (NE.head fs) rcfg
- signalLoop (XConf d r' w fs is rcfg) actions signal strs
+ r' <- W.repositionWin d w (NE.head fs) rcfg
+ signalLoop (T.XConf d r' w fs is rcfg) actions signalv strs
-parseSegments :: Config -> TVar [String] -> IO [[Segment]]
+parseSegments :: C.Config -> STM.TVar [String] -> IO [[P.Segment]]
parseSegments conf v = do
- s <- readTVarIO v
+ s <- STM.readTVarIO v
let l:c:r:_ = s ++ repeat ""
- liftIO $ mapM (parseString conf) [l, c, r]
+ MR.liftIO $ mapM (P.parseString conf) [l, c, r]
-updateIconCache :: XConf -> [[Segment]] -> IO XConf
-updateIconCache xc@(XConf d _ w _ c cfg) segs = do
- c' <- updateCache d w c (iconRoot cfg) [p | (Icon p, _, _, _) <- concat segs]
- return $ xc {iconCache = c'}
+updateIconCache :: T.XConf -> [[P.Segment]] -> IO T.XConf
+updateIconCache xc@(T.XConf d _ w _ c cfg) segs = do
+ let paths = [p | (P.Icon p, _, _, _) <- concat segs]
+ c' <- Bitmap.updateCache d w c (C.iconRoot cfg) paths
+ return $ xc {T.iconCache = c'}
-updateConfigPosition :: Display -> Config -> IO Config
+updateConfigPosition :: X11.Display -> C.Config -> IO C.Config
updateConfigPosition disp cfg =
- case position cfg of
- OnScreen n o -> do
- srs <- getScreenInfo disp
+ case C.position cfg of
+ C.OnScreen n o -> do
+ srs <- Xinerama.getScreenInfo disp
return (if n == length srs
- then (cfg {position = OnScreen 1 o})
- else (cfg {position = OnScreen (n+1) o}))
- o -> return (cfg {position = OnScreen 1 o})
+ then (cfg {C.position = C.OnScreen 1 o})
+ else (cfg {C.position = C.OnScreen (n+1) o}))
+ o -> return (cfg {C.position = C.OnScreen 1 o})
-runActions :: [ActionPos] -> Button -> Position -> IO ()
+runActions :: [T.ActionPos] -> A.Button -> X11.Position -> IO ()
runActions actions button pos =
- mapM_ runAction $
- filter (\(Spawn b _) -> button `elem` b) $
+ mapM_ A.runAction $
+ filter (\(A.Spawn b _) -> button `elem` b) $
concatMap (\(a,_,_) -> a) $
filter (\(_, from, to) -> pos >= from && pos <= to) actions