Wee refactorings

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