-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.SDL.TTF.Attributes
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-----------------------------------------------------------------------------
module Graphics.UI.SDL.TTF.Attributes
    ( getFontStyle
    , setFontStyle
    , fontHeight
    , fontAscent
    , fontDescent
    , fontLineSkip
    , fontFaces
    , fontFaceIsFixedWidth
    , fontFaceFamilyName
    , fontFaceStyleName
    , tryTextSize
    , textSize
    , tryUTF8Size
    , utf8Size
    , FontStyle(..)
    ) where

import Foreign
import Foreign.C
import Prelude hiding (Enum(..))

import Graphics.UI.SDL.TTF.Types
import Graphics.UI.SDL.Utilities
import Graphics.UI.SDL.General

data FontStyle
    = StyleBold
    | StyleItalic
    | StyleUnderline
      deriving (Int -> FontStyle -> ShowS
[FontStyle] -> ShowS
FontStyle -> String
(Int -> FontStyle -> ShowS)
-> (FontStyle -> String)
-> ([FontStyle] -> ShowS)
-> Show FontStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FontStyle -> ShowS
showsPrec :: Int -> FontStyle -> ShowS
$cshow :: FontStyle -> String
show :: FontStyle -> String
$cshowList :: [FontStyle] -> ShowS
showList :: [FontStyle] -> ShowS
Show,FontStyle -> FontStyle -> Bool
(FontStyle -> FontStyle -> Bool)
-> (FontStyle -> FontStyle -> Bool) -> Eq FontStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FontStyle -> FontStyle -> Bool
== :: FontStyle -> FontStyle -> Bool
$c/= :: FontStyle -> FontStyle -> Bool
/= :: FontStyle -> FontStyle -> Bool
Eq,Eq FontStyle
Eq FontStyle
-> (FontStyle -> FontStyle -> Ordering)
-> (FontStyle -> FontStyle -> Bool)
-> (FontStyle -> FontStyle -> Bool)
-> (FontStyle -> FontStyle -> Bool)
-> (FontStyle -> FontStyle -> Bool)
-> (FontStyle -> FontStyle -> FontStyle)
-> (FontStyle -> FontStyle -> FontStyle)
-> Ord FontStyle
FontStyle -> FontStyle -> Bool
FontStyle -> FontStyle -> Ordering
FontStyle -> FontStyle -> FontStyle
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FontStyle -> FontStyle -> Ordering
compare :: FontStyle -> FontStyle -> Ordering
$c< :: FontStyle -> FontStyle -> Bool
< :: FontStyle -> FontStyle -> Bool
$c<= :: FontStyle -> FontStyle -> Bool
<= :: FontStyle -> FontStyle -> Bool
$c> :: FontStyle -> FontStyle -> Bool
> :: FontStyle -> FontStyle -> Bool
$c>= :: FontStyle -> FontStyle -> Bool
>= :: FontStyle -> FontStyle -> Bool
$cmax :: FontStyle -> FontStyle -> FontStyle
max :: FontStyle -> FontStyle -> FontStyle
$cmin :: FontStyle -> FontStyle -> FontStyle
min :: FontStyle -> FontStyle -> FontStyle
Ord)

instance Bounded FontStyle where
    minBound :: FontStyle
minBound = FontStyle
StyleBold
    maxBound :: FontStyle
maxBound = FontStyle
StyleUnderline

instance Enum FontStyle Int where
    fromEnum :: FontStyle -> Int
fromEnum FontStyle
StyleBold = Int
1
    fromEnum FontStyle
StyleItalic = Int
2
    fromEnum FontStyle
StyleUnderline = Int
4
    toEnum :: Int -> FontStyle
toEnum Int
1 = FontStyle
StyleBold
    toEnum Int
2 = FontStyle
StyleItalic
    toEnum Int
4 = FontStyle
StyleUnderline
    toEnum Int
_ = String -> FontStyle
forall a. HasCallStack => String -> a
error String
"Graphics.UI.SDL.TTF.Attributes.toEnum: bad argument"
    succ :: FontStyle -> FontStyle
succ FontStyle
StyleBold = FontStyle
StyleItalic
    succ FontStyle
StyleItalic = FontStyle
StyleUnderline
    succ FontStyle
_ = String -> FontStyle
forall a. HasCallStack => String -> a
error String
"Graphics.UI.SDL.TTF.Attributes.succ: bad argument"
    pred :: FontStyle -> FontStyle
pred FontStyle
StyleItalic = FontStyle
StyleBold
    pred FontStyle
StyleUnderline = FontStyle
StyleItalic
    pred FontStyle
_ = String -> FontStyle
forall a. HasCallStack => String -> a
error String
"Graphics.UI.SDL.TTF.Attributes.pred: bad argument"
    enumFromTo :: FontStyle -> FontStyle -> [FontStyle]
enumFromTo FontStyle
x FontStyle
y | FontStyle
x FontStyle -> FontStyle -> Bool
forall a. Ord a => a -> a -> Bool
> FontStyle
y = []
                   | FontStyle
x FontStyle -> FontStyle -> Bool
forall a. Eq a => a -> a -> Bool
== FontStyle
y = [FontStyle
y]
                   | Bool
True = FontStyle
x FontStyle -> [FontStyle] -> [FontStyle]
forall a. a -> [a] -> [a]
: FontStyle -> FontStyle -> [FontStyle]
forall a b. Enum a b => a -> a -> [a]
enumFromTo (FontStyle -> FontStyle
forall a b. Enum a b => a -> a
succ FontStyle
x) FontStyle
y


-- int TTF_GetFontStyle(TTF_Font *font)
foreign import ccall unsafe "TTF_GetFontStyle" ttfGetFontStyle :: Ptr FontStruct -> IO CInt
getFontStyle :: Font -> IO [FontStyle]
getFontStyle :: Font -> IO [FontStyle]
getFontStyle Font
font
    = Font -> (Ptr FontStruct -> IO [FontStyle]) -> IO [FontStyle]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font ((Ptr FontStruct -> IO [FontStyle]) -> IO [FontStyle])
-> (Ptr FontStruct -> IO [FontStyle]) -> IO [FontStyle]
forall a b. (a -> b) -> a -> b
$
      (CInt -> [FontStyle]) -> IO CInt -> IO [FontStyle]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [FontStyle]
forall a b. (Bounded a, Enum a b, Bits b, Num b) => b -> [a]
fromBitmask (Int -> [FontStyle]) -> (CInt -> Int) -> CInt -> [FontStyle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (IO CInt -> IO [FontStyle])
-> (Ptr FontStruct -> IO CInt) -> Ptr FontStruct -> IO [FontStyle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr FontStruct -> IO CInt
ttfGetFontStyle

-- void TTF_SetFontStyle(TTF_Font *font, int style)
foreign import ccall unsafe "TTF_SetFontStyle" ttfSetFontStyle :: Ptr FontStruct -> CInt -> IO ()
setFontStyle :: Font -> [FontStyle] -> IO ()
setFontStyle :: Font -> [FontStyle] -> IO ()
setFontStyle Font
font [FontStyle]
style
    = Font -> (Ptr FontStruct -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font ((Ptr FontStruct -> IO ()) -> IO ())
-> (Ptr FontStruct -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr FontStruct
fontPtr ->
      Ptr FontStruct -> CInt -> IO ()
ttfSetFontStyle Ptr FontStruct
fontPtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> ([FontStyle] -> Int) -> [FontStyle] -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FontStyle] -> Int
forall a b. (Enum a b, Bits b, Num b) => [a] -> b
toBitmask ([FontStyle] -> CInt) -> [FontStyle] -> CInt
forall a b. (a -> b) -> a -> b
$ [FontStyle]
style)

-- int TTF_FontHeight(TTF_Font *font)
foreign import ccall unsafe "TTF_FontHeight" ttfFontHeight :: Ptr FontStruct -> IO CInt
fontHeight :: Font -> IO Int
fontHeight :: Font -> IO Int
fontHeight Font
font = (CInt -> Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$ Font -> (Ptr FontStruct -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CInt
ttfFontHeight

-- int TTF_FontAscent(TTF_Font *font)
foreign import ccall unsafe "TTF_FontAscent" ttfFontAscent :: Ptr FontStruct -> IO CInt
fontAscent :: Font -> IO Int
fontAscent :: Font -> IO Int
fontAscent Font
font = (CInt -> Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$ Font -> (Ptr FontStruct -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CInt
ttfFontAscent

-- int TTF_FontDecent(TTF_Font *font)
foreign import ccall unsafe "TTF_FontAscent" ttfFontDescent :: Ptr FontStruct -> IO CInt
fontDescent :: Font -> IO Int
fontDescent :: Font -> IO Int
fontDescent Font
font = (CInt -> Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$ Font -> (Ptr FontStruct -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CInt
ttfFontDescent

-- int TTF_FontLineSkip(TTF_Font *font)
foreign import ccall unsafe "TTF_FontLineSkip" ttfFontLineSkip :: Ptr FontStruct -> IO CInt
fontLineSkip :: Font -> IO Int
fontLineSkip :: Font -> IO Int
fontLineSkip Font
font = (CInt -> Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$ Font -> (Ptr FontStruct -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CInt
ttfFontLineSkip

-- long TTF_FontFaces(TTF_Font *font);
foreign import ccall unsafe "TTF_FontFaces" ttfFontFaces :: Ptr FontStruct -> IO CInt
fontFaces :: Font -> IO Int
fontFaces :: Font -> IO Int
fontFaces Font
font = (CInt -> Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$ Font -> (Ptr FontStruct -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CInt
ttfFontFaces

-- int SDLCALL TTF_FontFaceIsFixedWidth(TTF_Font *font);
foreign import ccall unsafe "TTF_FontFaceIsFixedWidth" ttfFontFaceIsFixedWidth :: Ptr FontStruct -> IO CInt
fontFaceIsFixedWidth :: Font -> IO Int
fontFaceIsFixedWidth :: Font -> IO Int
fontFaceIsFixedWidth Font
font = (CInt -> Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$ Font -> (Ptr FontStruct -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CInt
ttfFontFaceIsFixedWidth

-- char * SDLCALL TTF_FontFaceFamilyName(TTF_Font *font);
foreign import ccall unsafe "TTF_FontFaceFamilyName" ttfFontFaceFamilyName :: Ptr FontStruct -> IO CString
fontFaceFamilyName :: Font -> IO String
fontFaceFamilyName :: Font -> IO String
fontFaceFamilyName Font
font = Font -> (Ptr FontStruct -> IO CString) -> IO CString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CString
ttfFontFaceFamilyName IO CString -> (CString -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString

-- char * SDLCALL TTF_FontFaceStyleName(TTF_Font *font);
foreign import ccall unsafe "TTF_FontFaceStyleName" ttfFontFaceStyleName :: Ptr FontStruct -> IO CString
fontFaceStyleName :: Font -> IO String
fontFaceStyleName :: Font -> IO String
fontFaceStyleName Font
font = Font -> (Ptr FontStruct -> IO CString) -> IO CString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font Ptr FontStruct -> IO CString
ttfFontFaceStyleName IO CString -> (CString -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString


getSize :: (Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt) -> Font -> String -> IO (Maybe (Int,Int))
getSize :: (Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt)
-> Font -> String -> IO (Maybe (Int, Int))
getSize Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt
getter Font
font String
string
    = String
-> (CString -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int))
forall a. String -> (CString -> IO a) -> IO a
withCString String
string ((CString -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int)))
-> (CString -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ \CString
cString ->
      (Ptr CInt -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int)))
-> (Ptr CInt -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
width ->
      (Ptr CInt -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int)))
-> (Ptr CInt -> IO (Maybe (Int, Int))) -> IO (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
height ->
      Font
-> (Ptr FontStruct -> IO (Maybe (Int, Int)))
-> IO (Maybe (Int, Int))
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Font
font ((Ptr FontStruct -> IO (Maybe (Int, Int)))
 -> IO (Maybe (Int, Int)))
-> (Ptr FontStruct -> IO (Maybe (Int, Int)))
-> IO (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ \Ptr FontStruct
fontPtr ->
      do CInt
ret <- Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt
getter Ptr FontStruct
fontPtr CString
cString Ptr CInt
width Ptr CInt
height
         case CInt
ret of
           CInt
0 -> do [CInt
w,CInt
h] <- (Ptr CInt -> IO CInt) -> [Ptr CInt] -> IO [CInt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek [Ptr CInt
width,Ptr CInt
height]
                   Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
w,CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
h))
           CInt
_ -> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Int)
forall a. Maybe a
Nothing

-- int SDLCALL TTF_SizeText(TTF_Font *font, const char *text, int *w, int *h);
foreign import ccall unsafe "TTF_SizeText" ttfSizeText
    :: Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt
tryTextSize :: Font -> String -> IO (Maybe (Int,Int))
tryTextSize :: Font -> String -> IO (Maybe (Int, Int))
tryTextSize = (Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt)
-> Font -> String -> IO (Maybe (Int, Int))
getSize Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt
ttfSizeText

textSize :: Font -> String -> IO (Int,Int)
textSize :: Font -> String -> IO (Int, Int)
textSize Font
font String
string = String -> IO (Maybe (Int, Int)) -> IO (Int, Int)
forall a. String -> IO (Maybe a) -> IO a
unwrapMaybe String
"TTF_SizeText" (Font -> String -> IO (Maybe (Int, Int))
tryTextSize Font
font String
string)

-- int SDLCALL TTF_SizeUTF8(TTF_Font *font, const char *text, int *w, int *h);
foreign import ccall unsafe "TTF_SizeUTF8" ttfSizeUTF8
    :: Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt
tryUTF8Size :: Font -> String -> IO (Maybe (Int,Int))
tryUTF8Size :: Font -> String -> IO (Maybe (Int, Int))
tryUTF8Size = (Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt)
-> Font -> String -> IO (Maybe (Int, Int))
getSize Ptr FontStruct -> CString -> Ptr CInt -> Ptr CInt -> IO CInt
ttfSizeUTF8

utf8Size :: Font -> String -> IO (Int,Int)
utf8Size :: Font -> String -> IO (Int, Int)
utf8Size Font
font String
string = String -> IO (Maybe (Int, Int)) -> IO (Int, Int)
forall a. String -> IO (Maybe a) -> IO a
unwrapMaybe String
"TTF_SizeUTF8" (Font -> String -> IO (Maybe (Int, Int))
tryUTF8Size Font
font String
string)