content: {-# LANGUAGE CPP #-}
  ----------------------------------------------------------------------------
  -- |
  -- 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
      , fi
      ) where
  
  import XMonad
  import Foreign
  import Control.Applicative
  import Control.Exception as E
  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
                  | 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)
  
  econst :: a -> IOException -> a
  econst = const
  
  -- | 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 $ E.catch (getIt d) (fallBack d)
        where getIt    d = loadQueryFont d s
              fallBack d = econst $ 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 $ E.catch (getIt d) (fallBack d)
    return fs
        where getIt    d = createFontSet d s
              fallBack d = econst $ 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 switches 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
        fmap Utf8 $ initUtf8Font s
  #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 | AlignRightOffset Int
                  deriving (Show, Read)
  
  -- | 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));
              AlignRightOffset offset -> fi (w - (fi width + 1)) - fi offset;
    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
  
  -- | Short-hand for 'fromIntegral'
  fi :: (Integral a, Num b) => a -> b
  fi = fromIntegral
  