measure-text.hs

Measuring.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}

module Measuring
    ( Engine
    , FTError(..)
    , createEngine
    , measureText
    ) where

import Control.Concurrent
import Control.Exception
import Control.Monad

import Graphics.Rendering.FreeType.Internal
import Graphics.Rendering.FreeType.Internal.GlyphSlot
import Graphics.Rendering.FreeType.Internal.Face
import Graphics.Rendering.FreeType.Internal.Vector

import Foreign.Storable
import Foreign.Marshal
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Ptr

import Data.Bits
import Data.Typeable
import Data.Word

import System.IO.Unsafe

foreign import ccall "&finalizer" finalizer :: FunPtr (Ptr Engine -> IO ())

data FTError = FTError String CInt deriving(Show, Typeable)
instance Exception FTError

ft :: String -> IO CInt -> IO ()
ft n f = do
    e <- f
    unless (e == 0) $ throwIO (FTError n e)

newtype Engine = Engine (MVar (ForeignPtr Engine)) -- FontFace, Library

createEngine :: FilePath -> Int -> Engine
createEngine fontName sz = unsafePerformIO $ do
    lib <- alloca $ \p -> ft "Init_FreeType" (ft_Init_FreeType p) >> peek p
    fc  <- withCString fontName $ \font -> alloca $ \p ->
        ft "New_Face" (ft_New_Face lib font 0 p) >> peek p
    ft "Set_Pixel_Sizes" $ ft_Set_Pixel_Sizes fc 0 (fromIntegral sz)
    ptr <- mallocBytes (sizeOfPtr * 2)

    poke (castPtr ptr) fc
    poke (plusPtr ptr sizeOfPtr) lib

    f <- newForeignPtr finalizer ptr >>= newMVar
    return $ Engine f
  where
    sizeOfPtr = sizeOf (undefined :: Ptr a)
{-# NOINLINE createEngine #-}

charAdvX :: Engine -> Char -> IO Word64
charAdvX (Engine engine) c = withMVar engine $ \fp -> withForeignPtr fp $ \ptr -> do
        fc <- peek (castPtr ptr)
        slot <- peek $ glyph fc
        ft "Load_Char" $ ft_Load_Char fc (fromIntegral i) 0
        FT_Vector x _ <- peek $ advance slot
        return (fromIntegral x)
  where
    i = fromEnum c

measureText :: Engine -> String -> Word64
measureText engine s = unsafePerformIO (foldM (\i a -> (i+) `fmap` charAdvX engine a) 0 s) `shiftR` 6
{-# NOINLINE measureText #-}