{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module SDL.Font
(
initialize
, version
, quit
, Font(..)
, PointSize
, load
, Index
, loadIndex
, decode
, decodeIndex
, free
, Color
, solid
, shaded
, blended
, size
, Style(..)
, getStyle
, setStyle
, Outline
, getOutline
, setOutline
, Hinting(..)
, getHinting
, setHinting
, Kerning
, getKerning
, setKerning
, isMonospace
, familyName
, styleName
, height
, ascent
, descent
, lineSkip
, getKerningSize
, glyphProvided
, glyphIndex
, glyphMetrics
, solidGlyph
, shadedGlyph
, blendedGlyph
, blendedWrapped
) where
import Control.Exception (throwIO)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits ((.&.), (.|.))
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackCString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Foreign (lengthWord16, unsafeCopyToPtr)
import Data.Word (Word8, Word16)
import Foreign.C.String (CString, withCString)
import Foreign.C.Types (CUShort, CInt)
import Foreign.Marshal.Alloc (allocaBytes, alloca)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (peek, pokeByteOff)
import GHC.Generics (Generic)
import SDL (Surface(..), SDLException(SDLCallFailed))
import SDL.Internal.Exception
import SDL.Raw.Filesystem (rwFromConstMem)
import SDL.Vect (V4(..))
import qualified SDL.Raw
import qualified SDL.Raw.Font
version :: (Integral a, MonadIO m) => m (a, a, a)
version = liftIO $ do
SDL.Raw.Version major minor patch <- peek =<< SDL.Raw.Font.getVersion
return (fromIntegral major, fromIntegral minor, fromIntegral patch)
initialize :: MonadIO m => m ()
initialize = do
init'd <- (== 1) `fmap` SDL.Raw.Font.wasInit
unless init'd $
throwIfNeg_ "SDL.Font.initialize" "TTF_Init" SDL.Raw.Font.init
quit :: MonadIO m => m ()
quit = SDL.Raw.Font.quit
newtype Font = Font { unwrap :: Ptr SDL.Raw.Font.Font }
deriving (Eq, Show)
type PointSize = Int
load :: MonadIO m => FilePath -> PointSize -> m Font
load path pts =
fmap Font .
throwIfNull "SDL.Font.load" "TTF_OpenFont" .
liftIO . withCString path $
flip SDL.Raw.Font.openFont $ fromIntegral pts
decode :: MonadIO m => ByteString -> PointSize -> m Font
decode bytes pts = liftIO .
unsafeUseAsCStringLen bytes $ \(cstr, len) -> do
rw <- rwFromConstMem (castPtr cstr) (fromIntegral len)
fmap Font .
throwIfNull "SDL.Font.decode" "TTF_OpenFontRW" $
SDL.Raw.Font.openFont_RW rw 0 $ fromIntegral pts
type Index = Int
loadIndex :: MonadIO m => FilePath -> PointSize -> Index -> m Font
loadIndex path pts i =
fmap Font .
throwIfNull "SDL.Font.loadIndex" "TTF_OpenFontIndex" .
liftIO . withCString path $ \cpath ->
SDL.Raw.Font.openFontIndex cpath (fromIntegral pts) (fromIntegral i)
decodeIndex :: MonadIO m => ByteString -> PointSize -> Index -> m Font
decodeIndex bytes pts i = liftIO .
unsafeUseAsCStringLen bytes $ \(cstr, len) -> do
rw <- rwFromConstMem (castPtr cstr) (fromIntegral len)
fmap Font .
throwIfNull "SDL.Font.decodeIndex" "TTF_OpenFontIndexRW" $
SDL.Raw.Font.openFontIndex_RW rw 0 (fromIntegral pts) (fromIntegral i)
free :: MonadIO m => Font -> m ()
free = SDL.Raw.Font.closeFont . unwrap
type Color = V4 Word8
unmanaged :: Ptr SDL.Raw.Surface -> Surface
unmanaged p = Surface p Nothing
solid :: MonadIO m => Font -> Color -> Text -> m SDL.Surface
solid (Font font) (V4 r g b a) text =
fmap unmanaged .
throwIfNull "SDL.Font.solid" "TTF_RenderUNICODE_Solid" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderUNICODE_Solid font (castPtr ptr) fg
shaded :: MonadIO m => Font -> Color -> Color -> Text -> m SDL.Surface
shaded (Font font) (V4 r g b a) (V4 r2 g2 b2 a2) text =
fmap unmanaged .
throwIfNull "SDL.Font.shaded" "TTF_RenderUNICODE_Shaded" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
with (SDL.Raw.Color r2 g2 b2 a2) $ \bg ->
SDL.Raw.Font.renderUNICODE_Shaded font (castPtr ptr) fg bg
blended :: MonadIO m => Font -> Color -> Text -> m SDL.Surface
blended (Font font) (V4 r g b a) text =
fmap unmanaged .
throwIfNull "SDL.Font.blended" "TTF_RenderUNICODE_Blended" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderUNICODE_Blended font (castPtr ptr) fg
withText :: Text -> (Ptr Word16 -> IO a) -> IO a
withText text act =
allocaBytes len $ \ptr -> do
unsafeCopyToPtr text ptr
pokeByteOff ptr (len - 2) (0 :: CUShort)
act ptr
where
len = 2*(lengthWord16 text + 1)
fromMaskWith :: (Enum a, Bounded a) => (a -> CInt) -> CInt -> [a]
fromMaskWith convert cint = concatMap (\a -> find (a, convert a)) [minBound..]
where
find (a, i) = [a | i == i .&. cint]
toMaskWith :: (a -> CInt) -> [a] -> CInt
toMaskWith convert = foldr ((.|.) . convert) 0
data Style
= Bold
| Italic
| Underline
| Strikethrough
deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show)
styleToCInt :: Style -> CInt
styleToCInt =
\case
Bold -> SDL.Raw.Font.TTF_STYLE_BOLD
Italic -> SDL.Raw.Font.TTF_STYLE_ITALIC
Underline -> SDL.Raw.Font.TTF_STYLE_UNDERLINE
Strikethrough -> SDL.Raw.Font.TTF_STYLE_STRIKETHROUGH
getStyle :: MonadIO m => Font -> m [Style]
getStyle = fmap (fromMaskWith styleToCInt) . SDL.Raw.Font.getFontStyle . unwrap
setStyle :: MonadIO m => Font -> [Style] -> m ()
setStyle (Font font) = SDL.Raw.Font.setFontStyle font . toMaskWith styleToCInt
type Outline = Int
getOutline :: MonadIO m => Font -> m Outline
getOutline = fmap fromIntegral . SDL.Raw.Font.getFontOutline . unwrap
setOutline :: MonadIO m => Font -> Outline -> m ()
setOutline (Font font) = SDL.Raw.Font.setFontOutline font . fromIntegral
data Hinting
= Normal
| Light
| Mono
| None
deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show)
hintingToCInt :: Hinting -> CInt
hintingToCInt =
\case
Normal -> SDL.Raw.Font.TTF_HINTING_NORMAL
Light -> SDL.Raw.Font.TTF_HINTING_LIGHT
Mono -> SDL.Raw.Font.TTF_HINTING_MONO
None -> SDL.Raw.Font.TTF_HINTING_NONE
cIntToHinting :: CInt -> Hinting
cIntToHinting =
\case
SDL.Raw.Font.TTF_HINTING_NORMAL -> Normal
SDL.Raw.Font.TTF_HINTING_LIGHT -> Light
SDL.Raw.Font.TTF_HINTING_MONO -> Mono
SDL.Raw.Font.TTF_HINTING_NONE -> None
_ -> error "SDL.Font.cIntToHinting received unknown TTF_HINTING."
getHinting :: MonadIO m => Font -> m Hinting
getHinting = fmap cIntToHinting . SDL.Raw.Font.getFontHinting . unwrap
setHinting :: MonadIO m => Font -> Hinting -> m ()
setHinting (Font font) = SDL.Raw.Font.setFontHinting font . hintingToCInt
type Kerning = Bool
getKerning :: MonadIO m => Font -> m Kerning
getKerning = fmap toBool . SDL.Raw.Font.getFontKerning . unwrap
setKerning :: MonadIO m => Font -> Kerning -> m ()
setKerning (Font font) = SDL.Raw.Font.setFontKerning font . fromBool
height :: MonadIO m => Font -> m Int
height = fmap fromIntegral . SDL.Raw.Font.fontHeight . unwrap
ascent :: MonadIO m => Font -> m Int
ascent = fmap fromIntegral . SDL.Raw.Font.fontAscent . unwrap
descent :: MonadIO m => Font -> m Int
descent = fmap fromIntegral . SDL.Raw.Font.fontDescent . unwrap
lineSkip :: MonadIO m => Font -> m Int
lineSkip = fmap fromIntegral . SDL.Raw.Font.fontLineSkip . unwrap
isMonospace :: MonadIO m => Font -> m Bool
isMonospace = fmap toBool . SDL.Raw.Font.fontFaceIsFixedWidth . unwrap
cStringToText :: MonadIO m => CString -> m Text
cStringToText = fmap decodeUtf8 . liftIO . unsafePackCString
onlyIfM :: Monad m => Bool -> m a -> m (Maybe a)
onlyIfM = \case
False -> return . const Nothing
True -> fmap Just
familyName :: MonadIO m => Font -> m (Maybe Text)
familyName (Font font) = do
cstr <- SDL.Raw.Font.fontFaceFamilyName font
onlyIfM (cstr /= nullPtr) $ cStringToText cstr
styleName :: MonadIO m => Font -> m (Maybe Text)
styleName (Font font) = do
cstr <- SDL.Raw.Font.fontFaceStyleName font
onlyIfM (cstr /= nullPtr) $ cStringToText cstr
glyphProvided :: MonadIO m => Font -> Char -> m Bool
glyphProvided font ch =
glyphIndex font ch >>= \case
Just _ -> return True
Nothing -> return False
{-# INLINE fromChar #-}
fromChar :: Integral a => Char -> a
fromChar = fromIntegral . fromEnum
glyphIndex :: MonadIO m => Font -> Char -> m (Maybe Int)
glyphIndex (Font font) ch =
SDL.Raw.Font.glyphIsProvided font (fromChar ch)
>>= \case
0 -> return Nothing
i -> return . Just $ fromIntegral i
glyphMetrics :: MonadIO m => Font -> Char -> m (Maybe (Int, Int, Int, Int, Int))
glyphMetrics (Font font) ch =
liftIO .
alloca $ \minx ->
alloca $ \maxx ->
alloca $ \miny ->
alloca $ \maxy ->
alloca $ \advn -> do
let chi = fromChar ch
r <- SDL.Raw.Font.glyphMetrics font chi minx maxx miny maxy advn
if r /= 0 then
return Nothing
else do
a <- fromIntegral <$> peek minx
b <- fromIntegral <$> peek maxx
c <- fromIntegral <$> peek miny
d <- fromIntegral <$> peek maxy
e <- fromIntegral <$> peek advn
return $ Just (a, b, c, d, e)
size :: MonadIO m => Font -> Text -> m (Int, Int)
size (Font font) text =
liftIO .
withText text $ \ptr ->
alloca $ \w ->
alloca $ \h ->
SDL.Raw.Font.sizeUNICODE font (castPtr ptr) w h
>>= \case
0 -> do
w' <- fromIntegral <$> peek w
h' <- fromIntegral <$> peek h
return (w', h')
_ -> do
err <- getError
throwIO $ SDLCallFailed "SDL.Font.size" "TTF_SizeUNICODE" err
solidGlyph :: MonadIO m => Font -> Color -> Char -> m SDL.Surface
solidGlyph (Font font) (V4 r g b a) ch =
fmap unmanaged .
throwIfNull "SDL.Font.solidGlyph" "TTF_RenderGlyph_Solid" .
liftIO .
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderGlyph_Solid font (fromChar ch) fg
shadedGlyph :: MonadIO m => Font -> Color -> Color -> Char -> m SDL.Surface
shadedGlyph (Font font) (V4 r g b a) (V4 r2 g2 b2 a2) ch =
fmap unmanaged .
throwIfNull "SDL.Font.shadedGlyph" "TTF_RenderGlyph_Solid" .
liftIO .
with (SDL.Raw.Color r g b a) $ \fg ->
with (SDL.Raw.Color r2 g2 b2 a2) $ \bg ->
SDL.Raw.Font.renderGlyph_Shaded font (fromChar ch) fg bg
blendedGlyph :: MonadIO m => Font -> Color -> Char -> m SDL.Surface
blendedGlyph (Font font) (V4 r g b a) ch =
fmap unmanaged .
throwIfNull "SDL.Font.blendedGlyph" "TTF_RenderGlyph_Blended" .
liftIO .
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderGlyph_Blended font (fromChar ch) fg
blendedWrapped :: MonadIO m => Font -> Color -> Int -> Text -> m SDL.Surface
blendedWrapped (Font font) (V4 r g b a) wrapLength text =
fmap unmanaged .
throwIfNull "SDL.Font.blended" "TTF_RenderUNICODE_Blended_Wrapped" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderUNICODE_Blended_Wrapped font (castPtr ptr) fg $ fromIntegral wrapLength
getKerningSize :: MonadIO m => Font -> Index -> Index -> m Int
getKerningSize (Font font) prevIndex index =
fmap fromIntegral $ SDL.Raw.Font.getFontKerningSize font (fromIntegral prevIndex) (fromIntegral index)