summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Actions.hs4
-rw-r--r--src/Config.hs2
-rw-r--r--src/MinXft.hsc84
-rw-r--r--src/Parsers.hs5
-rw-r--r--src/Plugins/Kbd.hsc3
-rw-r--r--src/Plugins/Locks.hs37
-rw-r--r--src/Window.hs41
-rw-r--r--src/XUtil.hsc36
-rw-r--r--src/Xmobar.hs5
9 files changed, 173 insertions, 44 deletions
diff --git a/src/Actions.hs b/src/Actions.hs
index a739828..cd8ecb9 100644
--- a/src/Actions.hs
+++ b/src/Actions.hs
@@ -12,7 +12,7 @@
module Actions (Action(..), runAction, stripActions) where
-import System.Process (runCommand)
+import System.Process (system)
import Control.Monad (void)
import Text.Regex (Regex, subRegex, mkRegex, matchRegex)
import Graphics.X11.Types (Button)
@@ -21,7 +21,7 @@ data Action = Spawn [Button] String
deriving (Eq)
runAction :: Action -> IO ()
-runAction (Spawn _ s) = void $ runCommand s
+runAction (Spawn _ s) = void $ system (s ++ "&")
stripActions :: String -> String
stripActions s = case matchRegex actionRegex s of
diff --git a/src/Config.hs b/src/Config.hs
index bda8838..e7c25ad 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -54,6 +54,7 @@ data Config =
, position :: XPosition -- ^ Top Bottom or Static
, border :: Border -- ^ NoBorder TopB BottomB or FullB
, borderColor :: String -- ^ Border color
+ , borderWidth :: Int -- ^ Border width
, hideOnStart :: Bool -- ^ Hide (Unmap) the window on
-- initialization
, allDesktops :: Bool -- ^ Tell the WM to map to all desktops
@@ -110,6 +111,7 @@ defaultConfig =
, position = Top
, border = NoBorder
, borderColor = "#BFBFBF"
+ , borderWidth = 1
, hideOnStart = False
, lowerOnStart = True
, persistent = False
diff --git a/src/MinXft.hsc b/src/MinXft.hsc
index 327e95e..b2299af 100644
--- a/src/MinXft.hsc
+++ b/src/MinXft.hsc
@@ -2,7 +2,7 @@
------------------------------------------------------------------------------
-- |
-- Module: MinXft
--- Copyright: (c) 2012 Jose Antonio Ortega Ruiz
+-- Copyright: (c) 2012, 2014 Jose Antonio Ortega Ruiz
-- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007
-- License: BSD3-style (see LICENSE)
--
@@ -26,13 +26,18 @@ module MinXft ( AXftColor
, freeAXftColor
, withAXftDraw
, drawXftString
+ , drawXftString'
, drawXftRect
, openAXftFont
, closeAXftFont
, xftTxtExtents
+ , xftTxtExtents'
, xft_ascent
+ , xft_ascent'
, xft_descent
+ , xft_descent'
, xft_height
+ , xft_height'
)
where
@@ -45,6 +50,7 @@ import Foreign
import Foreign.C.Types
import Foreign.C.String
import Codec.Binary.UTF8.String as UTF8
+import Data.Char (ord)
#include <X11/Xft/Xft.h>
@@ -73,12 +79,21 @@ newtype AXftFont = AXftFont (Ptr AXftFont)
xft_ascent :: AXftFont -> IO Int
xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent}
+xft_ascent' :: [AXftFont] -> IO Int
+xft_ascent' = (fmap maximum) . (mapM xft_ascent)
+
xft_descent :: AXftFont -> IO Int
xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent}
+xft_descent' :: [AXftFont] -> IO Int
+xft_descent' = (fmap maximum) . (mapM xft_descent)
+
xft_height :: AXftFont -> IO Int
xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height}
+xft_height' :: [AXftFont] -> IO Int
+xft_height' = (fmap maximum) . (mapM xft_height)
+
foreign import ccall "XftTextExtentsUtf8"
cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()
@@ -90,6 +105,12 @@ xftTxtExtents d f string =
cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph
peek cglyph
+xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo
+xftTxtExtents' d fs string = do
+ chunks <- getChunks d fs string
+ let (_, _, gi, _, _) = last chunks
+ return gi
+
foreign import ccall "XftFontOpenName"
c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont
@@ -101,6 +122,14 @@ openAXftFont dpy screen name =
foreign import ccall "XftFontClose"
closeAXftFont :: Display -> AXftFont -> IO ()
+foreign import ccall "XftCharExists"
+ cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool)
+
+xftCharExists :: Display -> AXftFont -> Char -> IO Bool
+xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c)
+ where
+ bool 0 = False
+ bool _ = True
-- Drawing
fi :: (Integral a, Num b) => a -> b
@@ -111,6 +140,9 @@ newtype AXftDraw = AXftDraw (Ptr AXftDraw)
foreign import ccall "XftDrawCreate"
c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw
+foreign import ccall "XftDrawDisplay"
+ c_xftDrawDisplay :: AXftDraw -> IO Display
+
foreign import ccall "XftDrawDestroy"
c_xftDrawDestroy :: AXftDraw -> IO ()
@@ -130,6 +162,56 @@ drawXftString d c f x y string =
withArrayLen (map fi (UTF8.encode string))
(\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len))
+drawXftString' :: AXftDraw ->
+ AXftColor ->
+ [AXftFont] ->
+ Integer ->
+ Integer ->
+ String -> IO ()
+drawXftString' d c fs x y string = do
+ display <- c_xftDrawDisplay d
+ chunks <- getChunks display fs string
+ mapM_ (\(f, s, _, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks
+
+-- Split string and determine fonts/offsets for individual parts
+getChunks :: Display -> [AXftFont] -> [Char] ->
+ IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]
+getChunks disp fts str = do
+ chunks <- getFonts disp fts str
+ getOffsets (XGlyphInfo 0 0 0 0 0 0) chunks
+ where
+ -- Split string and determine fonts for individual parts
+ getFonts _ [] _ = return []
+ getFonts _ _ [] = return []
+ getFonts _ [ft] s = return [(ft, s)]
+ getFonts d fonts@(ft:_) s = do
+ -- Determine which glyph can be rendered by current font
+ glyphs <- mapM (xftCharExists d ft) s
+ -- Split string into parts that can/cannot be rendered
+ let splits = split (runs glyphs) s
+ -- Determine which font to render each chunk with
+ concat `fmap` mapM (getFont d fonts) splits
+
+ -- Determine fonts for substrings
+ getFont _ [] _ = return []
+ getFont _ [ft] (_, s) = return [(ft, s)] -- Last font, use it
+ getFont _ (ft:_) (True, s) = return [(ft, s)] -- Current font can render this substring
+ getFont d (_:fs) (False, s) = getFonts d fs s -- Fallback to next font
+
+ -- Helpers
+ runs [] = []
+ runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t
+ split [] _ = []
+ split ((x, c):xs) s = let (h, t) = splitAt c s in (x, h) : split xs t
+
+ -- Determine coordinates for chunks using extents
+ getOffsets _ [] = return []
+ getOffsets (XGlyphInfo _ _ x y xo yo) ((f, s):chunks) = do
+ (XGlyphInfo w' h' _ _ xo' yo') <- xftTxtExtents disp f s
+ let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo')
+ rest <- getOffsets gi chunks
+ return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : rest
+
foreign import ccall "XftDrawRect"
cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()
diff --git a/src/Parsers.hs b/src/Parsers.hs
index f7be1e3..5e6f4d6 100644
--- a/src/Parsers.hs
+++ b/src/Parsers.hs
@@ -199,8 +199,8 @@ parseConfig = runParser parseConf fields "Config" . stripComments
perms = permute $ Config
<$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition
- <|?> pBorder <|?> pBdColor <|?> pHideOnStart <|?> pAllDesktops
- <|?> pOverrideRedirect <|?> pPickBroadest
+ <|?> pBorder <|?> pBdColor <|?> pBdWidth <|?> pHideOnStart
+ <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest
<|?> pLowerOnStart <|?> pPersistent
<|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate
@@ -224,6 +224,7 @@ parseConfig = runParser parseConf fields "Config" . stripComments
pLowerOnStart = readField lowerOnStart "lowerOnStart"
pPersistent = readField persistent "persistent"
pBorder = readField border "border"
+ pBdWidth = readField borderWidth "borderWidth"
pAllDesktops = readField allDesktops "allDesktops"
pOverrideRedirect = readField overrideRedirect "overrideRedirect"
pPickBroadest = readField pickBroadest "pickBroadest"
diff --git a/src/Plugins/Kbd.hsc b/src/Plugins/Kbd.hsc
index 241dde4..318effc 100644
--- a/src/Plugins/Kbd.hsc
+++ b/src/Plugins/Kbd.hsc
@@ -276,6 +276,9 @@ xkbUseCoreKbd = #const XkbUseCoreKbd
xkbStateNotify :: CUInt
xkbStateNotify = #const XkbStateNotify
+xkbIndicatorStateNotify :: CUInt
+xkbIndicatorStateNotify = #const XkbIndicatorStateNotify
+
xkbMapNotify :: CUInt
xkbMapNotify = #const XkbMapNotify
diff --git a/src/Plugins/Locks.hs b/src/Plugins/Locks.hs
index 3c1e0a9..79b1583 100644
--- a/src/Plugins/Locks.hs
+++ b/src/Plugins/Locks.hs
@@ -20,6 +20,8 @@ import Data.Bits
import Control.Monad
import Graphics.X11.Xlib.Extras
import Plugins
+import Plugins.Kbd
+import XUtil (nextEvent')
data Locks = Locks
deriving (Read, Show)
@@ -30,22 +32,33 @@ locks = [ ( xK_Caps_Lock, "CAPS" )
, ( xK_Scroll_Lock, "SCROLL" )
]
+run' :: Display -> Window -> IO String
+run' d root = do
+ modMap <- getModifierMapping d
+ ( _, _, _, _, _, _, _, m ) <- queryPointer d root
+
+ ls <- filterM ( \( ks, _ ) -> do
+ kc <- keysymToKeycode d ks
+ return $ case find (elem kc . snd) modMap of
+ Nothing -> False
+ Just ( i, _ ) -> testBit m (fromIntegral i)
+ ) locks
+
+ return $ unwords $ map snd ls
+
instance Exec Locks where
alias Locks = "locks"
- rate Locks = 2
- run Locks = do
+ start Locks cb = do
d <- openDisplay ""
root <- rootWindow d (defaultScreen d)
+ _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m
- modMap <- getModifierMapping d
- ( _, _, _, _, _, _, _, m ) <- queryPointer d root
+ allocaXEvent $ \ep -> forever $ do
+ cb =<< run' d root
+ nextEvent' d ep
+ getEvent ep
- ls <- filterM ( \( ks, _ ) -> do
- kc <- keysymToKeycode d ks
- return $ case find (elem kc . snd) modMap of
- Nothing -> False
- Just ( i, _ ) -> testBit m (fromIntegral i)
- ) locks
closeDisplay d
-
- return $ unwords $ map snd ls
+ return ()
+ where
+ m = xkbAllStateComponentsMask
diff --git a/src/Window.hs b/src/Window.hs
index f7e1801..95ad3a3 100644
--- a/src/Window.hs
+++ b/src/Window.hs
@@ -164,20 +164,22 @@ getStaticStrutValues (Static cx cy cw ch) rwh
xe = xs + cw
getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]
-drawBorder :: Border -> Display -> Drawable -> GC -> Pixel
+drawBorder :: Border -> Int -> Display -> Drawable -> GC -> Pixel
-> Dimension -> Dimension -> IO ()
-drawBorder b d p gc c wi ht = case b of
+drawBorder b lw d p gc c wi ht = case b of
NoBorder -> return ()
- TopB -> drawBorder (TopBM 0) d p gc c w h
- BottomB -> drawBorder (BottomBM 0) d p gc c w h
- FullB -> drawBorder (FullBM 0) d p gc c w h
- TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0
- BottomBM m -> let rw = fi h - fi m in
- sf >> drawLine d p gc 0 rw (fi w) rw
- FullBM m -> let pad = 2 * fi m; mp = fi m in
- sf >> drawRectangle d p gc mp mp (w - pad) (h - pad)
- where sf = setForeground d gc c
- (w, h) = (wi - 1, ht - 1)
+ TopB -> drawBorder (TopBM 0) lw d p gc c wi ht
+ BottomB -> drawBorder (BottomBM 0) lw d p gc c wi ht
+ FullB -> drawBorder (FullBM 0) lw d p gc c wi ht
+ TopBM m -> sf >> sla >> drawLine d p gc 0 (fi m + boff) (fi wi) (fi m + boff)
+ BottomBM m -> let rw = fi ht - fi m + boff in
+ sf >> sla >> drawLine d p gc 0 rw (fi wi) rw
+ FullBM m -> let pad = 2 * fi m + 2 * fi boff'; mp = fi m + fi boff' in
+ sf >> sla >> drawRectangle d p gc mp mp (wi - pad) (ht - pad)
+ where sf = setForeground d gc c
+ sla = setLineAttributes d gc (fi lw) lineSolid capNotLast joinMiter
+ boff = borderOffset b lw
+ boff' = calcBorderOffset lw :: Int
hideWindow :: Display -> Window -> IO ()
hideWindow d w = do
@@ -193,3 +195,18 @@ showWindow r c d w = do
isMapped :: Display -> Window -> IO Bool
isMapped d w = ism <$> getWindowAttributes d w
where ism (WindowAttributes { wa_map_state = wms }) = wms /= waIsUnmapped
+
+borderOffset :: (Integral a) => Border -> Int -> a
+borderOffset b lw =
+ case b of
+ BottomB -> negate boffs
+ BottomBM _ -> negate boffs
+ TopB -> boffs
+ TopBM _ -> boffs
+ _ -> 0
+ where boffs = calcBorderOffset lw
+
+calcBorderOffset :: (Integral a) => Int -> a
+calcBorderOffset = ceiling . (/2) . toDouble
+ where toDouble = fi :: (Integral a) => a -> Double
+
diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index b1e885c..1217452 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -2,7 +2,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : XUtil
--- Copyright : (C) 2011, 2012, 2013 Jose Antonio Ortega Ruiz
+-- Copyright : (C) 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
-- (C) 2007 Andrea Rossato
-- License : BSD3
--
@@ -72,7 +72,7 @@ hGetLineSafe = hGetLine
data XFont = Core FontStruct
| Utf8 FontSet
#ifdef XFT
- | Xft AXftFont
+ | Xft [AXftFont]
#endif
-- | When initFont gets a font name that starts with 'xft:' it switchs
@@ -118,12 +118,22 @@ initUtf8Font d s = do
fallBack = const $ createFontSet d miscFixedFont
#ifdef XFT
-initXftFont :: Display -> String -> IO AXftFont
+initXftFont :: Display -> String -> IO [AXftFont]
initXftFont d s = do
setupLocale
- f <- openAXftFont d (defaultScreenOfDisplay d) (drop 4 s)
- addFinalizer f (closeAXftFont d f)
- return f
+ let fontNames = wordsBy (== ',') (drop 4 s)
+ fonts <- mapM openFont fontNames
+ return fonts
+ where
+ openFont fontName = do
+ f <- openAXftFont d (defaultScreenOfDisplay d) fontName
+ addFinalizer f (closeAXftFont d f)
+ return f
+ wordsBy p str = case dropWhile p str of
+ "" -> []
+ str' -> w : wordsBy p str''
+ where
+ (w, str'') = break p str'
#endif
textWidth :: Display -> XFont -> String -> IO Int
@@ -131,7 +141,7 @@ textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s
textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s
#ifdef XFT
textWidth dpy (Xft xftdraw) s = do
- gi <- xftTxtExtents dpy xftdraw s
+ gi <- xftTxtExtents' dpy xftdraw s
return $ xglyphinfo_xOff gi
#endif
@@ -145,9 +155,9 @@ textExtents (Utf8 fs) s = do
descent = fi $ rect_height rl + (fi $ rect_y rl)
return (ascent, descent)
#ifdef XFT
-textExtents (Xft xftfont) _ = do
- ascent <- fi `fmap` xft_ascent xftfont
- descent <- fi `fmap` xft_descent xftfont
+textExtents (Xft xftfonts) _ = do
+ ascent <- fi `fmap` xft_ascent' xftfonts
+ descent <- fi `fmap` xft_descent' xftfonts
return (ascent, descent)
#endif
@@ -167,15 +177,15 @@ printString d p (Utf8 fs) gc fc bc x y s =
io $ wcDrawImageString d p fs gc x y s
#ifdef XFT
-printString dpy drw fs@(Xft font) _ fc bc x y s = do
+printString dpy drw fs@(Xft fonts) _ fc bc x y s = do
(a,d) <- textExtents fs s
- gi <- xftTxtExtents dpy font s
+ gi <- xftTxtExtents' dpy fonts s
withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->
(drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi))
(y - (a + d) + 1)
(xglyphinfo_xOff gi)
(a + d)) >>
- (drawXftString draw fc' font x (y - 2) s)
+ (drawXftString' draw fc' fonts (toInteger x) (toInteger (y - 2)) s)
#endif
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 6ea8fab..91245e2 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -296,7 +296,7 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
printStrings p gc fs 1 R =<< strLn right
printStrings p gc fs 1 C =<< strLn center
-- draw 1 pixel border if requested
- io $ drawBorder (border c) d p gc bdcolor wid ht
+ io $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht
-- copy the pixmap with the new string to the window
io $ copyArea d p w gc 0 0 wid ht 0 0
-- free up everything (we do not want to leak memory!)
@@ -315,9 +315,10 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
Text t -> io $ textExtents fontst t
Icon _ -> return (0, 0)
let (conf,d) = (config &&& display) r
+ boffs = borderOffset (border conf) (borderWidth conf)
Rectangle _ _ wid ht = rect r
totSLen = foldr (\(_,_,len) -> (+) len) 0 sl
- valign = -1 + (fi ht + fi (as + ds)) `div` 2
+ valign = boffs-1 + (fi ht + fi (as + ds)) `div` 2
remWidth = fi wid - fi totSLen
offset = case a of
C -> (remWidth + offs) `div` 2
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-31 19:27:57 +0000