diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parsers.hs | 34 | ||||
| -rw-r--r-- | src/Types.hs | 3 | ||||
| -rw-r--r-- | src/XGraphic.hs | 47 | ||||
| -rw-r--r-- | src/XUtil.hsc | 42 | ||||
| -rw-r--r-- | src/Xmobar.hs | 13 |
5 files changed, 122 insertions, 17 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 |