{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Xmobar.X11.Text
-- Copyright   :  (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz
--                (C) 2007 Andrea Rossato
-- License     :  BSD3
--
-- Maintainer  :  jao@gnu.org
-- Stability   :  unstable
-- Portability :  unportable
--
-----------------------------------------------------------------------------

module Xmobar.X11.Text
    ( XFont(..)
    , initFont
    , initCoreFont
    , initUtf8Font
    , textExtents
    , textWidth
    ) where

import Control.Exception (SomeException, handle)
import Data.List
import Foreign
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 )

#if defined XFT
import Xmobar.X11.MinXft
import Graphics.X11.Xrender
#else
import System.IO(hPutStrLn, stderr)
#endif

data XFont = Core FontStruct
           | Utf8 FontSet
#ifdef XFT
           | Xft  [AXftFont]
#endif

-- | When initFont gets a font name that starts with 'xft:' it switchs
-- to the Xft backend Example: 'xft:Sans-10'
initFont :: Display -> String -> IO XFont
initFont :: Display -> String -> IO XFont
initFont Display
d String
s =
       let xftPrefix :: String
xftPrefix = String
"xft:" in
       if  String
xftPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s then
#ifdef XFT
           ([AXftFont] -> XFont) -> IO [AXftFont] -> IO XFont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [AXftFont] -> XFont
Xft (IO [AXftFont] -> IO XFont) -> IO [AXftFont] -> IO XFont
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO [AXftFont]
initXftFont Display
d String
s
#else
           do
               hPutStrLn stderr $ "Warning: Xmobar must be built with "
                   ++ "the with_xft flag to support font '" ++ s
                   ++ ".' Falling back on default."
               initFont d miscFixedFont
#endif
       else
           (FontSet -> XFont) -> IO FontSet -> IO XFont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FontSet -> XFont
Utf8 (IO FontSet -> IO XFont) -> IO FontSet -> IO XFont
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO FontSet
initUtf8Font Display
d String
s

miscFixedFont :: String
miscFixedFont :: String
miscFixedFont = String
"-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*"

-- | Given a fontname returns the font structure. If the font name is
--  not valid the default font will be loaded and returned.
initCoreFont :: Display -> String -> IO FontStruct
initCoreFont :: Display -> String -> IO FontStruct
initCoreFont Display
d String
s = do
  FontStruct
f <- (SomeException -> IO FontStruct) -> IO FontStruct -> IO FontStruct
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO FontStruct
fallBack IO FontStruct
getIt
  FontStruct -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer FontStruct
f (Display -> FontStruct -> IO ()
freeFont Display
d FontStruct
f)
  FontStruct -> IO FontStruct
forall (m :: * -> *) a. Monad m => a -> m a
return FontStruct
f
      where getIt :: IO FontStruct
getIt = Display -> String -> IO FontStruct
loadQueryFont Display
d String
s
            fallBack :: SomeException -> IO FontStruct
            fallBack :: SomeException -> IO FontStruct
fallBack = IO FontStruct -> SomeException -> IO FontStruct
forall a b. a -> b -> a
const (IO FontStruct -> SomeException -> IO FontStruct)
-> IO FontStruct -> SomeException -> IO FontStruct
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO FontStruct
loadQueryFont Display
d String
miscFixedFont

-- | Given a fontname returns the font structure. If the font name is
--  not valid the default font will be loaded and returned.
initUtf8Font :: Display -> String -> IO FontSet
initUtf8Font :: Display -> String -> IO FontSet
initUtf8Font Display
d String
s = do
  ([String]
_,String
_,FontSet
f) <- (SomeException -> IO ([String], String, FontSet))
-> IO ([String], String, FontSet) -> IO ([String], String, FontSet)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ([String], String, FontSet)
fallBack IO ([String], String, FontSet)
getIt
  FontSet -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer FontSet
f (Display -> FontSet -> IO ()
freeFontSet Display
d FontSet
f)
  FontSet -> IO FontSet
forall (m :: * -> *) a. Monad m => a -> m a
return FontSet
f
      where getIt :: IO ([String], String, FontSet)
getIt = Display -> String -> IO ([String], String, FontSet)
createFontSet Display
d String
s
            fallBack :: SomeException -> IO ([String], String, FontSet)
            fallBack :: SomeException -> IO ([String], String, FontSet)
fallBack = IO ([String], String, FontSet)
-> SomeException -> IO ([String], String, FontSet)
forall a b. a -> b -> a
const (IO ([String], String, FontSet)
 -> SomeException -> IO ([String], String, FontSet))
-> IO ([String], String, FontSet)
-> SomeException
-> IO ([String], String, FontSet)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO ([String], String, FontSet)
createFontSet Display
d String
miscFixedFont

#ifdef XFT
initXftFont :: Display -> String -> IO [AXftFont]
initXftFont :: Display -> String -> IO [AXftFont]
initXftFont Display
d String
s = do
  let fontNames :: [String]
fontNames = (Char -> Bool) -> String -> [String]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
4 String
s)
  (String -> IO AXftFont) -> [String] -> IO [AXftFont]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO AXftFont
openFont [String]
fontNames
  where
    openFont :: String -> IO AXftFont
openFont String
fontName = do
        AXftFont
f <- Display -> Screen -> String -> IO AXftFont
openAXftFont Display
d (Display -> Screen
defaultScreenOfDisplay Display
d) String
fontName
        AXftFont -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer AXftFont
f (Display -> AXftFont -> IO ()
closeAXftFont Display
d AXftFont
f)
        AXftFont -> IO AXftFont
forall (m :: * -> *) a. Monad m => a -> m a
return AXftFont
f
    wordsBy :: (Char -> Bool) -> String -> [String]
wordsBy Char -> Bool
p String
str = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
p String
str of
                        String
""   -> []
                        String
str' -> String
w String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
wordsBy Char -> Bool
p String
str''
                                where
                                    (String
w, String
str'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
p String
str'
#endif

textWidth :: Display -> XFont -> String -> IO Int
textWidth :: Display -> XFont -> String -> IO Int
textWidth Display
_   (Utf8 FontSet
fs) String
s = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FontSet -> String -> Int32
wcTextEscapement FontSet
fs String
s
textWidth Display
_   (Core FontStruct
fs) String
s = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FontStruct -> String -> Int32
Xlib.textWidth FontStruct
fs String
s
#ifdef XFT
textWidth Display
dpy (Xft [AXftFont]
xftdraw) String
s = do
    XGlyphInfo
gi <- Display -> [AXftFont] -> String -> IO XGlyphInfo
xftTxtExtents' Display
dpy [AXftFont]
xftdraw String
s
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ XGlyphInfo -> Int
xglyphinfo_xOff XGlyphInfo
gi
#endif

textExtents :: XFont -> String -> IO (Int32,Int32)
textExtents :: XFont -> String -> IO (Int32, Int32)
textExtents (Core FontStruct
fs) String
s = do
  let (FontDirection
_,Int32
a,Int32
d,CharStruct
_) = FontStruct -> String -> (FontDirection, Int32, Int32, CharStruct)
Xlib.textExtents FontStruct
fs String
s
  (Int32, Int32) -> IO (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
a,Int32
d)
textExtents (Utf8 FontSet
fs) String
s = do
  let (Rectangle
_,Rectangle
rl)  = FontSet -> String -> (Rectangle, Rectangle)
wcTextExtents FontSet
fs String
s
      ascent :: Int32
ascent  = Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ - (Rectangle -> Int32
rect_y Rectangle
rl)
      descent :: Int32
descent = Dimension -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dimension -> Int32) -> Dimension -> Int32
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_height Rectangle
rl Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Int32 -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Int32
rect_y Rectangle
rl)
  (Int32, Int32) -> IO (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
ascent, Int32
descent)
#ifdef XFT
textExtents (Xft [AXftFont]
xftfonts) String
_ = do
  Int32
ascent  <- Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> IO Int -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [AXftFont] -> IO Int
xft_ascent'  [AXftFont]
xftfonts
  Int32
descent <- Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> IO Int -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [AXftFont] -> IO Int
xft_descent' [AXftFont]
xftfonts
  (Int32, Int32) -> IO (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
ascent, Int32
descent)
#endif