    {-# 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