summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Parsers.hs34
-rw-r--r--src/Types.hs3
-rw-r--r--src/XGraphic.hs47
-rw-r--r--src/XUtil.hsc42
-rw-r--r--src/Xmobar.hs13
-rw-r--r--xmobar.cabal2
6 files changed, 123 insertions, 18 deletions
diff --git a/src/Parsers.hs b/src/Parsers.hs
index c658be6..4703733 100644
--- a/src/Parsers.hs
+++ b/src/Parsers.hs
@@ -17,9 +17,11 @@ module Parsers
( parseString
, parseTemplate
, parseConfig
+ , Widget(..)
) where
import Config
+import Types
import Runnable
import Commands
@@ -27,24 +29,28 @@ import qualified Data.Map as Map
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Perm
+type ColorString = String
+
-- | Runs the string parser
-parseString :: Config -> String -> IO [(String, String)]
+parseString :: Config -> String -> IO [(Widget, ColorString)]
parseString c s =
case parse (stringParser (fgColor c)) "" s of
- Left _ -> return [("Could not parse string: " ++ s, fgColor c)]
+ Left _ -> return [(Text $ "Could not parse string: " ++ s, fgColor c)]
Right x -> return (concat x)
-- | Gets the string and combines the needed parsers
-stringParser :: String -> Parser [[(String, String)]]
-stringParser c = manyTill (textParser c <|> colorParser) eof
+stringParser :: String -> Parser [[(Widget, ColorString)]]
+stringParser c = manyTill (textParser c <|> try (iconParser c) <|> colorParser) eof
-- | Parses a maximal string without color markup.
-textParser :: String -> Parser [(String, String)]
+textParser :: String -> Parser [(Widget, ColorString)]
textParser c = do s <- many1 $
noneOf "<" <|>
- ( try $ notFollowedBy' (char '<')
- (string "fc=" <|> string "/fc>" ) )
- return [(s, c)]
+ (try $ notFollowedBy' (char '<')
+ (string "fc=" <|>
+ string "icon=" <|> string "/fc>"))
+ return [(Text s, c)]
+
-- | Wrapper for notFollowedBy that returns the result of the first parser.
-- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy
@@ -54,11 +60,19 @@ notFollowedBy' p e = do x <- p
notFollowedBy $ try (e >> return '*')
return x
+icon :: Parser String
+icon = many1 $ noneOf ">"
+
+iconParser :: String -> Parser [(Widget, ColorString)]
+iconParser c = do
+ i <- between (string "<icon=") (string ">") icon
+ return [(Icon i, c)]
+
-- | Parsers a string wrapped in a color specification.
-colorParser :: Parser [(String, String)]
+colorParser :: Parser [(Widget, ColorString)]
colorParser = do
c <- between (string "<fc=") (string ">") colors
- s <- manyTill (textParser c <|> colorParser) (try $ string "</fc>")
+ s <- manyTill (try (textParser c <|> iconParser c) <|> colorParser) (try $ string "</fc>")
return (concat s)
-- | Parses a color specification (hex or named)
diff --git a/src/Types.hs b/src/Types.hs
new file mode 100644
index 0000000..3fcc6de
--- /dev/null
+++ b/src/Types.hs
@@ -0,0 +1,3 @@
+module Types where
+
+data Widget = Text String | Icon String
diff --git a/src/XGraphic.hs b/src/XGraphic.hs
new file mode 100644
index 0000000..9343580
--- /dev/null
+++ b/src/XGraphic.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : XGraphic
+-- Copyright : Copyright © 2013 Edward O'Callaghan. All Rights Reserved.
+-- License : BSD3
+--
+-- Maintainer : Edward O'Callaghan - <victoredwardocallaghan@gmail.com>
+-- Stability : unstable
+-- Portability : unportable
+--
+-----------------------------------------------------------------------------
+
+module XGraphic
+ ( readBitmapFile
+ ) where
+
+import Graphics.X11.Xlib
+--import Graphics.X11.Xlib.Misc
+import Foreign
+import Foreign.C
+
+-- | interface to the X11 library function @XWriteBitmapFile@.
+readBitmapFile :: Display -> Drawable -> String
+ -> IO (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt)
+readBitmapFile display d filename =
+ withCString filename $ \ c_filename ->
+ alloca $ \ width_return ->
+ alloca $ \ height_return ->
+ alloca $ \ bitmap_return ->
+ alloca $ \ x_hot_return ->
+ alloca $ \ y_hot_return -> do
+ _ <- xReadBitmapFile display d c_filename width_return height_return
+ bitmap_return x_hot_return y_hot_return
+ width <- peek width_return
+ height <- peek height_return
+ bitmap <- peek bitmap_return
+ x_hot <- peek x_hot_return
+ y_hot <- peek y_hot_return
+ let m_x_hot | x_hot == -1 = Nothing
+ | otherwise = Just x_hot
+ m_y_hot | y_hot == -1 = Nothing
+ | otherwise = Just y_hot
+ return (fromIntegral width, fromIntegral height, bitmap, m_x_hot, m_y_hot)
+foreign import ccall unsafe "X11/Xlib.h XReadBitmapFile"
+ xReadBitmapFile :: Display -> Drawable -> CString -> Ptr CInt -> Ptr CInt
+ -> Ptr Pixmap -> Ptr CInt -> Ptr CInt -> IO CInt
diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index 21dcf3e..f0a4b2d 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -33,12 +33,17 @@ import Control.Monad.Trans
import Control.Exception (SomeException, handle)
import Foreign
-- import Foreign.C.Types
+import Data.Foldable (forM_)
import Graphics.X11.Xlib hiding (textExtents, textWidth)
import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth)
import Graphics.X11.Xlib.Extras
import System.Mem.Weak ( addFinalizer )
import System.Posix.Types (Fd(..))
+import System.Directory (doesFileExist)
import System.IO
+import XGraphic
+import Types
+
#if defined XFT || defined UTF8
# if __GLASGOW_HASKELL__ < 612
import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine)
@@ -68,6 +73,11 @@ hGetLineSafe = UTF8.hGetLine
hGetLineSafe = hGetLine
#endif
+data Bitmap = Bitmap { width :: Dimension
+ , height :: Dimension
+ , pixmap :: Pixmap
+ }
+
-- Hide the Core Font/Xft switching here
data XFont = Core FontStruct
| Utf8 FontSet
@@ -151,23 +161,49 @@ textExtents (Xft xftfont) _ = do
return (ascent, descent)
#endif
+loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap)
+loadBitmap d w p = do
+ exist <- doesFileExist p
+ if exist
+ then do
+ (bw, bh, bp, _, _) <- readBitmapFile d w p
+ return $ Just $ Bitmap bw bh bp
+ else
+ return Nothing
+
+drawBitmap :: Display -> Drawable -> XFont -> GC -> String -> String
+ -> Position -> Position -> Bitmap -> IO ()
+drawBitmap d p _ gc fc bc x y i = do
+ withColors d [fc, bc] $ \[fc', bc'] -> do
+ setForeground d gc fc'
+ setBackground d gc bc'
+ io $ copyPlane d (pixmap i) p gc 0 0 (width i) (height i) x (y - (fi $ height i)) 1
+
printString :: Display -> Drawable -> XFont -> GC -> String -> String
+ -> Position -> Position -> Widget -> IO ()
+printString d p fs gc fc bc x y w = do
+ case w of
+ (Text s) -> printString' d p fs gc fc bc x y s
+ (Icon i) -> do bitmap <- loadBitmap d p i
+ forM_ bitmap $ drawBitmap d p fs gc fc bc x y
+
+printString' :: Display -> Drawable -> XFont -> GC -> String -> String
-> Position -> Position -> String -> IO ()
-printString d p (Core fs) gc fc bc x y s = do
+printString' d p (Core fs) gc fc bc x y s = do
setFont d gc $ fontFromFontStruct fs
withColors d [fc, bc] $ \[fc', bc'] -> do
setForeground d gc fc'
setBackground d gc bc'
drawImageString d p gc x y s
-printString d p (Utf8 fs) gc fc bc x y s =
+printString' d p (Utf8 fs) gc fc bc x y s =
withColors d [fc, bc] $ \[fc', bc'] -> do
setForeground d gc fc'
setBackground d gc bc'
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 font) _ fc bc x y s = do
(a,d) <- textExtents fs s
gi <- xftTxtExtents dpy font s
withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 5fc0cd4..7730620 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -231,12 +231,15 @@ updateWin v = do
-- $print
-- | Draws in and updates the window
-drawInWin :: Rectangle -> [[(String, String)]] -> X ()
+drawInWin :: Rectangle -> [[(Widget, String)]] -> X ()
drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
r <- ask
let (c,d ) = (config &&& display) r
(w,fs) = (window &&& fontS ) r
- strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw))
+ strLn = io . mapM getWidth
+ getWidth (Text s,cl) = textWidth d fs s >>= \tw -> return (Text s,cl,fi tw)
+ getWidth (Icon s,cl) = return (Icon s,cl,fi ht)
+
withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do
gc <- io $ createGC d w
-- create a pixmap to write to and fill it with a rectangle
@@ -261,11 +264,13 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
-- | An easy way to print the stuff we need to print
printStrings :: Drawable -> GC -> XFont -> Position
- -> Align -> [(String, String, Position)] -> X ()
+ -> Align -> [(Widget, String, Position)] -> X ()
printStrings _ _ _ _ _ [] = return ()
printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
r <- ask
- (as,ds) <- io $ textExtents fontst s
+ let fromWidget (Text t) = t
+ fromWidget (Icon t) = t
+ (as,ds) <- io $ textExtents fontst (fromWidget s)
let (conf,d) = (config &&& display) r
Rectangle _ _ wid ht = rect r
totSLen = foldr (\(_,_,len) -> (+) len) 0 sl
diff --git a/xmobar.cabal b/xmobar.cabal
index c44a40f..3f2ecd2 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -74,7 +74,7 @@ executable xmobar
hs-source-dirs: src
main-is: Main.hs
other-modules:
- Xmobar, Config, Parsers, Commands, Localize,
+ Xmobar, Config, Parsers, Commands, Localize, XGraphic,
XUtil, StatFS, Runnable, ColorCache, Window, Signal,
Plugins, Plugins.BufferedPipeReader,
Plugins.CommandReader, Plugins.Date, Plugins.EWMH,
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 09:35:09 +0000