diff options
| -rw-r--r-- | XMonad/Layout/ShowWName.hs | 4 | ||||
| -rw-r--r-- | XMonad/Prompt.hs | 8 | ||||
| -rw-r--r-- | XMonad/Util/Font.cpphs | 156 | ||||
| -rw-r--r-- | XMonad/Util/Font.hsc | 226 | ||||
| -rw-r--r-- | XMonad/Util/XUtils.hs | 3 | ||||
| -rw-r--r-- | xmonad-contrib.cabal | 11 |
6 files changed, 245 insertions, 163 deletions
diff --git a/XMonad/Layout/ShowWName.hs b/XMonad/Layout/ShowWName.hs index 20d39d6..7169081 100644 --- a/XMonad/Layout/ShowWName.hs +++ b/XMonad/Layout/ShowWName.hs @@ -91,8 +91,8 @@ flashName c (Rectangle _ _ wh ht) wrs = do d <- asks display n <- withWindowSet (return . S.tag . S.workspace . S.current) f <- initXMF (swn_font c) - width <- textWidthXMF d f n - (_,as,ds,_) <- textExtentsXMF f n + width <- textWidthXMF d f n + (as,ds) <- textExtentsXMF f n let hight = as + ds y = (fi ht - hight + 2) `div` 2 x = (fi wh - width + 2) `div` 2 diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs index 349d8c0..d1426a6 100644 --- a/XMonad/Prompt.hs +++ b/XMonad/Prompt.hs @@ -41,6 +41,8 @@ module XMonad.Prompt , splitInSubListsAt , breakAtSpace , uniqSort + , decodeInput + , encodeOutput ) where import XMonad hiding (config, io) @@ -336,7 +338,7 @@ keyPressHandle mask (ks,_) -- insert a character keyPressHandle _ (_,s) | s == "" = eventLoop handle - | otherwise = do insertString s + | otherwise = do insertString (decodeInput s) updateWindows eventLoop handle @@ -504,7 +506,7 @@ printPrompt drw = do ht = height c fsl <- io $ textWidthXMF (dpy st) fs f psl <- io $ textWidthXMF (dpy st) fs p - (_,asc,desc,_) <- io $ textExtentsXMF fs str + (asc,desc) <- io $ textExtentsXMF fs str let y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc x = (asc + desc) `div` 2 @@ -571,7 +573,7 @@ getComplWinDim compl = do (x,y) = case position c of Top -> (0,ht) Bottom -> (0, (0 + rem_height - actual_height)) - (_,asc,desc,_) <- io $ textExtentsXMF fs $ head compl + (asc,desc) <- io $ textExtentsXMF fs $ head compl let yp = fi $ (ht + fi (asc - desc)) `div` 2 xp = (asc + desc) `div` 2 yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..] diff --git a/XMonad/Util/Font.cpphs b/XMonad/Util/Font.cpphs deleted file mode 100644 index b6cf2ad..0000000 --- a/XMonad/Util/Font.cpphs +++ /dev/null @@ -1,156 +0,0 @@ ----------------------------------------------------------------------------- --- | --- Module : XMonad.Util.Font --- Copyright : (c) 2007 Andrea Rossato and Spencer Janssen --- License : BSD-style (see xmonad/LICENSE) --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- --- A module for abstracting a font facility over Core fonts and Xft --- ------------------------------------------------------------------------------ - -module XMonad.Util.Font ( - -- * Usage: - -- $usage - XMonadFont(..) - , initXMF - , releaseXMF - , initCoreFont - , releaseCoreFont - , Align (..) - , stringPosition - , textWidthXMF - , textExtentsXMF - , printStringXMF - , stringToPixel - ) where - - -import XMonad -import Foreign -import Control.Applicative -import Data.Maybe - -#ifdef XFT -import Data.List -import Graphics.X11.Xft -import Graphics.X11.Xrender -#endif - --- Hide the Core Font/Xft switching here -data XMonadFont = Core FontStruct -#ifdef XFT - | Xft XftFont -#endif - --- $usage --- See "Xmonad.Layout.Tabbed" or "XMonad.Prompt" for usage examples - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -stringToPixel :: (Functor m, MonadIO m) => Display -> String -> m Pixel -stringToPixel d s = fromMaybe fallBack <$> liftIO getIt - where getIt = initColor d s - fallBack = blackPixel d (defaultScreen d) - - --- | Given a fontname returns the font structure. If the font name is --- not valid the default font will be loaded and returned. -initCoreFont :: String -> X FontStruct -initCoreFont s = do - d <- asks display - io $ catch (getIt d) (fallBack d) - where getIt d = loadQueryFont d s - fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - -releaseCoreFont :: FontStruct -> X () -releaseCoreFont fs = do - d <- asks display - io $ freeFont d fs - --- | When initXMF gets a font name that starts with 'xft:' it switchs to the Xft backend --- Example: 'xft: Sans-10' -initXMF :: String -> X XMonadFont -initXMF s = -#ifdef XFT - if xftPrefix `isPrefixOf` s then - do - dpy <- asks display - xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s) - return (Xft xftdraw) - else -#endif - (initCoreFont s >>= (return . Core)) -#ifdef XFT - where xftPrefix = "xft:" -#endif - -releaseXMF :: XMonadFont -> X () -releaseXMF (Core fs) = releaseCoreFont fs -#ifdef XFT -releaseXMF (Xft xftfont) = do - dpy <- asks display - io $ xftFontClose dpy xftfont -#endif - -textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int -textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s -#ifdef XFT -textWidthXMF dpy (Xft xftdraw) s = liftIO $ do - gi <- xftTextExtents dpy xftdraw s - return $ xglyphinfo_width gi -#endif - -textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (FontDirection,Int32,Int32,CharStruct) -textExtentsXMF (Core fs) s = return $ textExtents fs s -#ifdef XFT -textExtentsXMF (Xft xftfont) _ = liftIO $ do - ascent <- xftfont_ascent xftfont - descent <- xftfont_descent xftfont - return (error "Font direction touched", fi ascent, fi descent, error "Font overall size touched") -#endif - --- | String position -data Align = AlignCenter | AlignRight | AlignLeft - --- | Return the string x and y 'Position' in a 'Rectangle', given a --- 'FontStruct' and the 'Align'ment -stringPosition :: XMonadFont -> Rectangle -> Align -> String -> X (Position,Position) -stringPosition fs (Rectangle _ _ w h) al s = do - dpy <- asks display - width <- io $ textWidthXMF dpy fs s - (_,a,d,_) <- io $ textExtentsXMF fs s - let y = fi $ ((h - fi (a + d)) `div` 2) + fi a; - x = case al of - AlignCenter -> fi (w `div` 2) - fi (width `div` 2) - AlignLeft -> 1 - AlignRight -> fi (w - (fi width + 1)); - return (x,y) - - -printStringXMF :: MonadIO m => Display -> Drawable -> XMonadFont -> GC -> String -> String - -> Position -> Position -> String -> m () -printStringXMF d p (Core fs) gc fc bc x y s = liftIO $ do - setFont d gc $ fontFromFontStruct fs - [fc',bc'] <- mapM (stringToPixel d) [fc,bc] - setForeground d gc fc' - setBackground d gc bc' - drawImageString d p gc x y s - -#ifdef XFT -printStringXMF dpy drw (Xft font) _ fc _ x y s = do - let screen = defaultScreenOfDisplay dpy; - colormap = defaultColormapOfScreen screen; - visual = defaultVisualOfScreen screen; - liftIO $ withXftDraw dpy drw visual colormap $ - \draw -> withXftColorName dpy visual colormap fc $ - \color -> xftDrawString draw color font x y s -#endif - - --- | Short-hand for 'fromIntegral' -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral diff --git a/XMonad/Util/Font.hsc b/XMonad/Util/Font.hsc new file mode 100644 index 0000000..5be594d --- /dev/null +++ b/XMonad/Util/Font.hsc @@ -0,0 +1,226 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Font +-- Copyright : (c) 2007 Andrea Rossato and Spencer Janssen +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for abstracting a font facility over Core fonts and Xft +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Font + ( -- * Usage: + -- $usage + XMonadFont(..) + , initXMF + , releaseXMF + , initCoreFont + , releaseCoreFont + , initUtf8Font + , releaseUtf8Font + , Align (..) + , stringPosition + , textWidthXMF + , textExtentsXMF + , printStringXMF + , stringToPixel + , decodeInput + , encodeOutput + ) where + +import XMonad +import Foreign +import Control.Applicative +import Data.Maybe + +#ifdef XFT +import Data.List +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +#if defined XFT || defined UTF8 +import Codec.Binary.UTF8.String (encodeString, decodeString) +import Foreign.C +#endif + +-- Hide the Core Font/Xft switching here +data XMonadFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft XftFont +#endif + +-- $usage +-- See "Xmonad.Layout.Tabbed" or "XMonad.Prompt" for usage examples + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +stringToPixel :: (Functor m, MonadIO m) => Display -> String -> m Pixel +stringToPixel d s = fromMaybe fallBack <$> io getIt + where getIt = initColor d s + fallBack = blackPixel d (defaultScreen d) + + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initCoreFont :: String -> X FontStruct +initCoreFont s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = loadQueryFont d s + fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseCoreFont :: FontStruct -> X () +releaseCoreFont fs = do + d <- asks display + io $ freeFont d fs + +initUtf8Font :: String -> X FontSet +initUtf8Font s = do + d <- asks display + (_,_,fs) <- io $ catch (getIt d) (fallBack d) + return fs + where getIt d = createFontSet d s + fallBack d = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseUtf8Font :: FontSet -> X () +releaseUtf8Font fs = do + d <- asks display + io $ freeFontSet d fs + +-- | When initXMF gets a font name that starts with 'xft:' it switchs to the Xft backend +-- Example: 'xft: Sans-10' +initXMF :: String -> X XMonadFont +initXMF s = +#ifdef XFT + if xftPrefix `isPrefixOf` s then + do io setupLocale + dpy <- asks display + xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s) + return (Xft xftdraw) + else +#endif +#ifdef UTF8 + (io setupLocale >> initUtf8Font s >>= (return . Utf8)) +#else + (initCoreFont s >>= (return . Core)) +#endif +#ifdef XFT + where xftPrefix = "xft:" +#endif + +releaseXMF :: XMonadFont -> X () +#ifdef XFT +releaseXMF (Xft xftfont) = do + dpy <- asks display + io $ xftFontClose dpy xftfont +#endif +releaseXMF (Utf8 fs) = releaseUtf8Font fs +releaseXMF (Core fs) = releaseCoreFont fs + + +textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int +textWidthXMF _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s +textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s +#ifdef XFT +textWidthXMF dpy (Xft xftdraw) s = liftIO $ do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32) +textExtentsXMF (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + (fi $ rect_y rl) + return (ascent, descent) +textExtentsXMF (Core fs) s = do + let (_,a,d,_) = textExtents fs s + return (a,d) +#ifdef XFT +textExtentsXMF (Xft xftfont) _ = io $ do + ascent <- fi `fmap` xftfont_ascent xftfont + descent <- fi `fmap` xftfont_descent xftfont + return (ascent, descent) +#endif + +-- | String position +data Align = AlignCenter | AlignRight | AlignLeft + +-- | Return the string x and y 'Position' in a 'Rectangle', given a +-- 'FontStruct' and the 'Align'ment +stringPosition :: (Functor m, MonadIO m) => Display -> XMonadFont -> Rectangle -> Align -> String -> m (Position,Position) +stringPosition dpy fs (Rectangle _ _ w h) al s = do + width <- textWidthXMF dpy fs s + (a,d) <- textExtentsXMF fs s + let y = fi $ ((h - fi (a + d)) `div` 2) + fi a; + x = case al of + AlignCenter -> fi (w `div` 2) - fi (width `div` 2) + AlignLeft -> 1 + AlignRight -> fi (w - (fi width + 1)); + return (x,y) + +printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String + -> Position -> Position -> String -> m () +printStringXMF d p (Core fs) gc fc bc x y s = io $ do + setFont d gc $ fontFromFontStruct fs + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + drawImageString d p gc x y s +printStringXMF d p (Utf8 fs) gc fc bc x y s = io $ do + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + io $ wcDrawImageString d p fs gc x y s +#ifdef XFT +printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + bcolor <- stringToPixel dpy bc + (a,d) <- textExtentsXMF fs s + gi <- io $ xftTextExtents dpy font s + io $ setForeground dpy gc bcolor + io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) + (y - fi a) + (fi $ xglyphinfo_xOff gi) + (fi $ a + d) + io $ withXftDraw dpy drw visual colormap $ + \draw -> withXftColorName dpy visual colormap fc $ + \color -> xftDrawString draw color font x y s +#endif + +decodeInput :: String -> String +#if defined XFT || defined UTF8 +decodeInput = decodeString +#else +decodeInput = id +#endif + +encodeOutput :: String -> String +#if defined XFT || defined UTF8 +encodeOutput = encodeString +#else +encodeOutput = id +#endif + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +#if defined XFT || defined UTF8 +#include <locale.h> +foreign import ccall unsafe "locale.h setlocale" + setlocale :: CInt -> CString -> IO CString + +setupLocale :: IO () +setupLocale = withCString "" $ \s -> do + setlocale (#const LC_ALL) s + return () +#endif diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs index aff7b4b..c72bd79 100644 --- a/XMonad/Util/XUtils.hs +++ b/XMonad/Util/XUtils.hs @@ -117,7 +117,8 @@ paintAndWrite :: Window -- ^ The window where to draw -> String -- ^ String to be printed -> X () paintAndWrite w fs wh ht bw bc borc ffc fbc al str = do - (x,y) <- stringPosition fs (Rectangle 0 0 wh ht) al str + d <- asks display + (x,y) <- stringPosition d fs (Rectangle 0 0 wh ht) al str paintWindow' w (Rectangle x y wh ht) bw bc borc ms where ms = Just (fs,ffc,fbc,str) diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index dcd0da2..1fb5420 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -34,6 +34,9 @@ flag small_base flag use_xft description: Use Xft to render text +flag with_utf8 + description: Enable Utf8 support + flag testing description: Testing mode default: False @@ -45,9 +48,15 @@ library build-depends: base < 3 if flag(use_xft) - build-depends: X11-xft >= 0.2 + build-depends: X11-xft >= 0.2, utf8-string + extensions: ForeignFunctionInterface cpp-options: -DXFT + if flag(with_utf8) + build-depends: utf8-string + extensions: ForeignFunctionInterface + cpp-options: -DUTF8 + build-depends: mtl, unix, X11>=1.4.1, xmonad==0.6 ghc-options: -Wall |