summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/app/Main.hs13
-rw-r--r--src/lib/Xmobar.hs32
-rw-r--r--src/lib/Xmobar/Window.hs19
-rw-r--r--src/lib/Xmobar/XUtil.hs (renamed from src/lib/Xmobar/XUtil.hsc)67
4 files changed, 53 insertions, 78 deletions
diff --git a/src/app/Main.hs b/src/app/Main.hs
index c96c47e..22834b1 100644
--- a/src/app/Main.hs
+++ b/src/app/Main.hs
@@ -40,6 +40,7 @@ import System.Posix.Files
import Control.Concurrent.Async (Async, cancel)
import Control.Exception (bracket)
import Control.Monad (unless)
+import Control.Monad.IO.Class (liftIO)
import Text.Read (readMaybe)
import Xmobar.Signal (setupSignalHandler, withDeferSignals)
@@ -100,9 +101,9 @@ splitTemplate conf =
-- | Reads the configuration files or quits with an error
readConfig :: FilePath -> IO (Config,[String])
readConfig f = do
- file <- io $ fileExist f
- s <- io $ if file then readFileSafe f else error $
- f ++ ": file not found!\n" ++ usage
+ file <- liftIO $ fileExist f
+ s <- liftIO $ if file then readFileSafe f else error $
+ f ++ ": file not found!\n" ++ usage
either (\err -> error $ f ++
": configuration file contains errors at:\n" ++ show err)
return $ parseConfig s
@@ -123,10 +124,10 @@ getXdgConfigFile = fmap (</> "xmobarrc") xmobarConfigDir
readDefaultConfig :: IO (Config,[String])
readDefaultConfig = do
xdgConfigFile <- getXdgConfigFile
- xdgConfigFileExists <- io $ fileExist xdgConfigFile
- home <- io $ getEnv "HOME"
+ xdgConfigFileExists <- liftIO $ fileExist xdgConfigFile
+ home <- liftIO $ getEnv "HOME"
let defaultConfigFile = home ++ "/.xmobarrc"
- defaultConfigFileExists <- io $ fileExist defaultConfigFile
+ defaultConfigFileExists <- liftIO $ fileExist defaultConfigFile
if xdgConfigFileExists
then readConfig xdgConfigFile
else if defaultConfigFileExists
diff --git a/src/lib/Xmobar.hs b/src/lib/Xmobar.hs
index e4eb4b7..4172780 100644
--- a/src/lib/Xmobar.hs
+++ b/src/lib/Xmobar.hs
@@ -253,14 +253,14 @@ updateString :: Config -> TVar [String]
updateString conf v = do
s <- readTVarIO v
let l:c:r:_ = s ++ repeat ""
- io $ mapM (parseString conf) [l, c, r]
+ liftIO $ mapM (parseString conf) [l, c, r]
updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]]
-> IO [([Action], Position, Position)]
updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
let (d,fs) = (display &&& fontListS) conf
strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
- strLn = io . mapM getCoords
+ strLn = liftIO . mapM getCoords
iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf)
getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw)
getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s)
@@ -288,46 +288,46 @@ drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do
r <- ask
let (c,d) = (config &&& display) r
(w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r
- strLn = io . mapM getWidth
+ strLn = liftIO . mapM getWidth
iconW i = maybe 0 Bitmap.width (lookup i $ iconS r)
getWidth (Text s,cl,i,_) =
textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw)
getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s)
- p <- io $ createPixmap d w wid ht
+ p <- liftIO $ createPixmap d w wid ht
(defaultDepthOfScreen (defaultScreenOfDisplay d))
#if XFT
- when (alpha c /= 255) (io $ drawBackground d p (bgColor c) (alpha c) wr)
+ when (alpha c /= 255) (liftIO $ drawBackground d p (bgColor c) (alpha c) wr)
#endif
withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do
- gc <- io $ createGC d w
+ gc <- liftIO $ createGC d w
#if XFT
when (alpha c == 255) $ do
#else
do
#endif
- io $ setForeground d gc bgcolor
- io $ fillRectangle d p gc 0 0 wid ht
+ liftIO $ setForeground d gc bgcolor
+ liftIO $ fillRectangle d p gc 0 0 wid ht
-- write to the pixmap the new string
printStrings p gc fs vs 1 L =<< strLn left
printStrings p gc fs vs 1 R =<< strLn right
printStrings p gc fs vs 1 C =<< strLn center
-- draw border if requested
- io $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht
+ liftIO $ 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
+ liftIO $ copyArea d p w gc 0 0 wid ht 0 0
-- free up everything (we do not want to leak memory!)
- io $ freeGC d gc
- io $ freePixmap d p
+ liftIO $ freeGC d gc
+ liftIO $ freePixmap d p
-- resync
- io $ sync d True
+ liftIO $ sync d True
verticalOffset :: (Integral b, Integral a, MonadIO m) =>
a -> Widget -> XFont -> Int -> Config -> m b
verticalOffset ht (Text t) fontst voffs _
| voffs > -1 = return $ fi voffs
| otherwise = do
- (as,ds) <- io $ textExtents fontst t
+ (as,ds) <- liftIO $ textExtents fontst t
let margin = (fi ht - fi ds - fi as) `div` 2
return $ fi as + margin - 1
verticalOffset ht (Icon _) _ _ conf
@@ -355,8 +355,8 @@ printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do
(f, _) -> (f, bgColor conf)
valign <- verticalOffset ht s (head fontlist) (voffs !! i) conf
case s of
- (Text t) -> io $ printString d dr fontst gc fc bc offset valign t alph
- (Icon p) -> io $ maybe (return ())
+ (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph
+ (Icon p) -> liftIO $ maybe (return ())
(drawBitmap d dr gc fc bc offset valign)
(lookup p (iconS r))
printStrings dr gc fontlist voffs (offs + l) a xs
diff --git a/src/lib/Xmobar/Window.hs b/src/lib/Xmobar/Window.hs
index c8228de..c8ba1bd 100644
--- a/src/lib/Xmobar/Window.hs
+++ b/src/lib/Xmobar/Window.hs
@@ -33,6 +33,18 @@ import Xmobar.XUtil
-- $window
+-- | Creates a window with the attribute override_redirect set to True.
+-- Windows Managers should not touch this kind of windows.
+newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window
+newWindow dpy scr rw (Rectangle x y w h) o = do
+ let visual = defaultVisualOfScreen scr
+ attrmask = if o then cWOverrideRedirect else 0
+ allocaSetWindowAttributes $
+ \attributes -> do
+ set_override_redirect attributes o
+ createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)
+ inputOutput visual attrmask attributes
+
-- | The function to create the initial window
createWin :: Display -> XFont -> Config -> IO (Rectangle,Window)
createWin d fs c = do
@@ -41,7 +53,7 @@ createWin d fs c = do
rootw <- rootWindow d dflt
(as,ds) <- textExtents fs "0"
let ht = as + ds + 4
- r = setPosition c (position c) srs (fi ht)
+ r = setPosition c (position c) srs (fromIntegral ht)
win <- newWindow d (defaultScreenOfDisplay d) rootw r (overrideRedirect c)
setProperties c d win
setStruts r c d win srs
@@ -55,11 +67,14 @@ repositionWin d win fs c = do
srs <- getScreenInfo d
(as,ds) <- textExtents fs "0"
let ht = as + ds + 4
- r = setPosition c (position c) srs (fi ht)
+ r = setPosition c (position c) srs (fromIntegral ht)
moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r)
setStruts r c d win srs
return r
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral
+
setPosition :: Config -> XPosition -> [Rectangle] -> Dimension -> Rectangle
setPosition c p rs ht =
case p' of
diff --git a/src/lib/Xmobar/XUtil.hsc b/src/lib/Xmobar/XUtil.hs
index 05e6fad..5093e59 100644
--- a/src/lib/Xmobar/XUtil.hsc
+++ b/src/lib/Xmobar/XUtil.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : XUtil
@@ -19,12 +21,9 @@ module Xmobar.XUtil
, textExtents
, textWidth
, printString
- , newWindow
, nextEvent'
, readFileSafe
, hGetLineSafe
- , io
- , fi
) where
import Control.Concurrent
@@ -41,12 +40,9 @@ import System.Posix.Types (Fd(..))
import System.IO
#if defined XFT || defined UTF8
-# if __GLASGOW_HASKELL__ < 612
-import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine)
-# else
-import qualified System.IO as UTF8 (readFile,hGetLine)
-# endif
+import qualified System.IO as S (readFile,hGetLine)
#endif
+
#if defined XFT
import Xmobar.MinXft
import Graphics.X11.Xrender
@@ -56,14 +52,14 @@ import Xmobar.ColorCache
readFileSafe :: FilePath -> IO String
#if defined XFT || defined UTF8
-readFileSafe = UTF8.readFile
+readFileSafe = S.readFile
#else
readFileSafe = readFile
#endif
hGetLineSafe :: Handle -> IO String
#if defined XFT || defined UTF8
-hGetLineSafe = UTF8.hGetLine
+hGetLineSafe = S.hGetLine
#else
hGetLineSafe = hGetLine
#endif
@@ -91,11 +87,7 @@ initFont d s =
initFont d miscFixedFont
#endif
else
-#if defined UTF8 || __GLASGOW_HASKELL__ >= 612
fmap Utf8 $ initUtf8Font d s
-#else
- fmap Core $ initCoreFont d s
-#endif
miscFixedFont :: String
miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*"
@@ -115,7 +107,6 @@ initCoreFont d s = do
-- not valid the default font will be loaded and returned.
initUtf8Font :: Display -> String -> IO FontSet
initUtf8Font d s = do
- setupLocale
(_,_,f) <- handle fallBack getIt
addFinalizer f (freeFontSet d f)
return f
@@ -126,7 +117,6 @@ initUtf8Font d s = do
#ifdef XFT
initXftFont :: Display -> String -> IO [AXftFont]
initXftFont d s = do
- setupLocale
let fontNames = wordsBy (== ',') (drop 4 s)
mapM openFont fontNames
where
@@ -142,8 +132,8 @@ initXftFont d s = do
#endif
textWidth :: Display -> XFont -> String -> IO Int
-textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s
-textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s
+textWidth _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s
+textWidth _ (Core fs) s = return $ fromIntegral $ Xlib.textWidth fs s
#ifdef XFT
textWidth dpy (Xft xftdraw) s = do
gi <- xftTxtExtents' dpy xftdraw s
@@ -156,13 +146,13 @@ textExtents (Core fs) s = do
return (a,d)
textExtents (Utf8 fs) s = do
let (_,rl) = wcTextExtents fs s
- ascent = fi $ - (rect_y rl)
- descent = fi $ rect_height rl + fi (rect_y rl)
+ ascent = fromIntegral $ - (rect_y rl)
+ descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl)
return (ascent, descent)
#ifdef XFT
textExtents (Xft xftfonts) _ = do
- ascent <- fi `fmap` xft_ascent' xftfonts
- descent <- fi `fmap` xft_descent' xftfonts
+ ascent <- fromIntegral `fmap` xft_ascent' xftfonts
+ descent <- fromIntegral `fmap` xft_descent' xftfonts
return (ascent, descent)
#endif
@@ -179,7 +169,7 @@ printString d p (Utf8 fs) gc fc bc x y s a =
withColors d [fc, bc] $ \[fc', bc'] -> do
setForeground d gc fc'
when (a == 255) (setBackground d gc bc')
- io $ wcDrawImageString d p fs gc x y s
+ liftIO $ wcDrawImageString d p fs gc x y s
#ifdef XFT
printString dpy drw fs@(Xft fonts) _ fc bc x y s al =
@@ -191,18 +181,6 @@ printString dpy drw fs@(Xft fonts) _ fc bc x y s al =
drawXftString' draw fc' fonts (toInteger x) (toInteger y) s
#endif
-
--- | Creates a window with the attribute override_redirect set to True.
--- Windows Managers should not touch this kind of windows.
-newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window
-newWindow dpy scr rw (Rectangle x y w h) o = do
- let visual = defaultVisualOfScreen scr
- attrmask = if o then cWOverrideRedirect else 0
- allocaSetWindowAttributes $
- \attributes -> do
- set_override_redirect attributes o
- createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)
- inputOutput visual attrmask attributes
-- | A version of nextEvent that does not block in foreign calls.
nextEvent' :: Display -> XEventPtr -> IO ()
nextEvent' d p = do
@@ -214,22 +192,3 @@ nextEvent' d p = do
nextEvent' d p
where
fd = connectionNumber d
-
-io :: MonadIO m => IO a -> m a
-io = liftIO
-
--- | Short-hand for 'fromIntegral'
-fi :: (Integral a, Num b) => a -> b
-fi = fromIntegral
-
-#if __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8)
-#include <locale.h>
-foreign import ccall unsafe "locale.h setlocale"
- setlocale :: CInt -> CString -> IO CString
-
-setupLocale :: IO ()
-setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return ()
-# else
-setupLocale :: IO ()
-setupLocale = return ()
-#endif
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-26 07:06:57 +0000