diff options
author | Spencer Janssen <sjanssen@cse.unl.edu> | 2007-11-16 22:57:20 +0100 |
---|---|---|
committer | Spencer Janssen <sjanssen@cse.unl.edu> | 2007-11-16 22:57:20 +0100 |
commit | 7cd1a62cf81826a72dc9a4ae6adc3b40dbd646da (patch) | |
tree | e00a604cba5c0f13fbd359aef7fb80db0d080e7a /XMonad/Util/Font.cpphs | |
parent | a4813570daddeb156e06110c3200a2b96dc808b7 (diff) | |
download | XMonadContrib-7cd1a62cf81826a72dc9a4ae6adc3b40dbd646da.tar.gz XMonadContrib-7cd1a62cf81826a72dc9a4ae6adc3b40dbd646da.tar.xz XMonadContrib-7cd1a62cf81826a72dc9a4ae6adc3b40dbd646da.zip |
Move XMonad.Util.Font to fix haddock generation
darcs-hash:20071116215720-a5988-b4f40df339aeed5736edcb35b1a85424403d947d.gz
Diffstat (limited to 'XMonad/Util/Font.cpphs')
-rw-r--r-- | XMonad/Util/Font.cpphs | 159 |
1 files changed, 159 insertions, 0 deletions
diff --git a/XMonad/Util/Font.cpphs b/XMonad/Util/Font.cpphs new file mode 100644 index 0000000..56fe43e --- /dev/null +++ b/XMonad/Util/Font.cpphs @@ -0,0 +1,159 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Font +-- Copyright : (c) 2007 Andrea Rossato +-- 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 Graphics.X11.Xlib +import Control.Monad.Reader +import XMonad +import Foreign +import XMonad.Operations + +#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 Tabbed or 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 :: String -> X Pixel +stringToPixel s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = initColor d s + fallBack d = const $ return $ 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 :: Display -> XMonadFont -> String -> IO Int +textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s +#ifdef XFT +textWidthXMF dpy (Xft xftdraw) s = do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_width gi +#endif + +textExtentsXMF :: Display -> XMonadFont -> String -> IO (FontDirection,Int32,Int32,CharStruct) +textExtentsXMF _ (Core fs) s = return $ textExtents fs s +#ifdef XFT +textExtentsXMF _ (Xft xftfont) _ = 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 dpy 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 :: Display -> Drawable -> XMonadFont -> GC -> String -> String + -> Position -> Position -> String -> X () +printStringXMF d p (Core fs) gc fc bc x y s = do + io $ setFont d gc $ fontFromFontStruct fs + [fc',bc'] <- mapM stringToPixel [fc,bc] + io $ setForeground d gc fc' + io $ setBackground d gc bc' + io $ 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; + io $ 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 |