{-# LANGUAGE PackageImports #-}
module Data.Text.Glyphize.Font where
import Data.ByteString
import Data.Text.Short
--import FreeType.Core.Base
import Data.Text.Glyphize.Buffer (Direction(..), dir2int)
import System.IO.Unsafe (unsafePerformIO)
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.C.String
import Data.Maybe (fromMaybe)
import Data.Word
import Data.Int
import Data.ByteString.Internal hiding (c2w)
import Codec.Binary.UTF8.Light (c2w)
import Control.Monad (forM)
type Face = ForeignPtr Face'
type Face_ = Ptr Face'
data Face'
foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Int
countFace :: ByteString -> Int
countFace bytes = unsafePerformIO $ do
blob <- bs2blob bytes
withForeignPtr blob hb_face_count
foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Int -> IO Face_
foreign import ccall "&hb_face_destroy" hb_face_destroy :: FunPtr (Face_ -> IO ())
createFace :: ByteString -> Int -> Face
createFace bytes index = unsafePerformIO $ do
blob <- bs2blob bytes
face <- withForeignPtr blob $ flip hb_face_create index
newForeignPtr hb_face_destroy face
--foreign import ccall "hb_ft_face_create_referenced" hb_ft_face_create_referenced
-- :: FT_Face -> Face_
--ftCreateFace :: FT_Face -> Face
--ftCreateFace =
-- unsafePerformIO . newForeignPtr hb_face_destroy . hb_ft_face_create_referenced
foreign import ccall "hb_face_get_empty" hb_face_get_empty :: Face_
emptyFace :: Face
emptyFace = unsafePerformIO $ newForeignPtr hb_face_destroy hb_face_get_empty
foreign import ccall "hb_face_get_glyph_count" hb_face_get_glyph_count :: Face_ -> Int
faceGlyphCount :: Face -> Int
faceGlyphCount = faceFunc hb_face_get_glyph_count
foreign import ccall "hb_face_get_index" hb_face_get_index :: Face_ -> Int
faceIndex :: Face -> Int
faceIndex = faceFunc hb_face_get_index
foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Int
faceUpem :: Face -> Int
faceUpem = faceFunc hb_face_get_upem
-- Defer implementation of other functions...
---
type Font = ForeignPtr Font'
type Font_ = Ptr Font'
data Font'
foreign import ccall "hb_font_create" hb_font_create :: Face_ -> IO Font_
foreign import ccall "hb_font_make_immutable" hb_font_make_immutable :: Font_ -> IO ()
foreign import ccall "&hb_font_destroy" hb_font_destroy :: FunPtr (Font_ -> IO ())
createFont :: Face -> Font
createFont fce = unsafePerformIO $ do
font <- withForeignPtr fce $ hb_font_create
hb_font_make_immutable font
newForeignPtr hb_font_destroy font
--foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced
-- :: FT_Face -> IO Face_
-- ftCreateFont :: FT_Face -> IO Font
-- ftCreateFont fce = unsafePerformIO $ do
-- font <- hb_ft_font_create_referenced
-- hb_font_make_immutable font
-- newForeignPtr hb_font_destroy font
foreign import ccall "hb_font_get_empty" hb_font_get_empty :: Font_
emptyFont :: Font
emptyFont = unsafePerformIO $ newForeignPtr hb_font_destroy hb_font_get_empty
foreign import ccall "hb_font_get_glyph" hb_font_get_glyph
:: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
fontGlyph :: Font -> Char -> Maybe Char -> Maybe Word32
fontGlyph font char var =
unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do
success <- hb_font_get_glyph font' (c2w char) (c2w $ fromMaybe '\0' var) ret
if success then return . Just =<< peek ret else return Nothing
foreign import ccall "hb_font_get_glyph_advance_for_direction"
hb_font_get_glyph_advance_for_direction
:: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO ()
fontGlyphAdvance :: Font -> Word32 -> Maybe Direction -> (Int32, Int32)
fontGlyphAdvance font glyph dir = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
hb_font_get_glyph_advance_for_direction font' glyph (dir2int dir) x' y'
x <- peek x'
y <- peek y'
return (x, y)
foreign import ccall "hb_font_get_glyph_contour_point" hb_font_get_glyph_contour_point
:: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphContourPoint :: Font -> Word32 -> Int -> Maybe (Int32, Int32)
fontGlyphContourPoint font glyph index = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
success <- hb_font_get_glyph_contour_point font' glyph index x' y'
if success
then do
x <- peek x'
y <- peek y'
return $ Just (x, y)
else return Nothing
foreign import ccall "hb_font_get_glyph_contour_point_for_origin"
hb_font_get_glyph_contour_point_for_origin
:: Font_ -> Word32 -> Int -> Int -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphContourPointForOrigin :: Font -> Word32 -> Int -> Maybe Direction -> Maybe (Int32, Int32)
fontGlyphContourPointForOrigin font glyph index dir = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
success <- hb_font_get_glyph_contour_point_for_origin font' glyph index
(dir2int dir) x' y'
if success
then do
x <- peek x'
y <- peek y'
return $ Just (x, y)
else return Nothing
data GlyphExtents = GlyphExtents {
xBearing :: Word32, yBearing :: Word32,
width :: Word32, height :: Word32
}
instance Storable GlyphExtents where
sizeOf (GlyphExtents a _ _ _) = 4 * sizeOf a
alignment (GlyphExtents a _ _ _) = alignment a
peek p = do
q <- return $ castPtr p
x <- peek q
y <- peekElemOff q 1
width <- peekElemOff q 2
height <- peekElemOff q 3
return $ GlyphExtents x y width height
poke p (GlyphExtents x y width height) = do
q <- return $ castPtr p
poke q x
pokeElemOff q 1 y
pokeElemOff q 2 width
pokeElemOff q 3 height
foreign import ccall "hb_font_get_glyph_extents" hb_font_get_glyph_extents
:: Font_ -> Word32 -> Ptr GlyphExtents -> IO Bool
fontGlyphExtents :: Font -> Word32 -> Maybe GlyphExtents
fontGlyphExtents font glyph = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
success <- hb_font_get_glyph_extents font' glyph ret
if success
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_glyph_extents_for_origin"
hb_font_get_glyph_extents_for_origin
:: Font_ -> Word32 -> Int -> Ptr GlyphExtents -> IO Bool
fontGlyphExtentsForOrigin :: Font -> Word32 -> Maybe Direction -> Maybe GlyphExtents
fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
ok <- hb_font_get_glyph_extents_for_origin font' glyph (dir2int dir) ret
if ok
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_glyph_from_name" hb_font_get_glyph_from_name
:: Font_ -> Ptr Word8 -> Int -> Ptr Word32 -> IO Bool
fontGlyphFromName :: Font -> ShortText -> Maybe Word32
fontGlyphFromName font name = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
let PS ptr offset size = toByteString name
success <- withForeignPtr ptr $ \ptr' ->
hb_font_get_glyph_from_name font' (plusPtr ptr' offset) (size - offset) ret
if success
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_glyph_h_advance" hb_font_get_glyph_h_advance
:: Font_ -> Word32 -> Word32
fontGlyphHAdvance :: Font -> Word32 -> Word32
fontGlyphHAdvance = fontFunc hb_font_get_glyph_h_advance
foreign import ccall "hb_font_get_glyph_h_kerning" hb_font_get_glyph_h_kerning
:: Font_ -> Word32 -> Word32 -> Word32
fontGlyphHKerning :: Font -> Word32 -> Word32 -> Word32
fontGlyphHKerning = fontFunc hb_font_get_glyph_h_kerning
foreign import ccall "hb_font_get_glyph_h_origin" hb_font_get_glyph_h_origin
:: Font_ -> Word32 -> Ptr Word32 -> Ptr Word32 -> IO Bool
fontGlyphHOrigin :: Font -> Word32 -> Maybe (Word32, Word32)
fontGlyphHOrigin font glyph = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
success <- hb_font_get_glyph_h_origin font' glyph x' y'
if success
then do
x <- peek x'
y <- peek y'
return $ Just (x, y)
else return Nothing
foreign import ccall "hb_font_get_glyph_kerning_for_direction"
hb_font_get_glyph_kerning_for_direction
:: Font_ -> Word32 -> Word32 -> Int -> Ptr Word32 -> Ptr Word32 -> IO ()
fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Word32, Word32)
fontGlyphKerningForDir font glyph1 glyph2 dir = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
hb_font_get_glyph_kerning_for_direction font' glyph1 glyph2 (dir2int dir) x' y'
x <- peek x'
y <- peek y'
return (x, y)
foreign import ccall "hb_font_get_glyph_name" hb_font_get_glyph_name
:: Font_ -> Word32 -> CString -> Int -> IO Bool
fontGlyphName :: Font -> Word32 -> Int -> Maybe String
fontGlyphName font glyph length = unsafePerformIO $
withForeignPtr font $ \font' -> allocaBytes length $ \ret -> do
success <- hb_font_get_glyph_name font' glyph ret length
if success
then return . Just =<< peekCString ret
else return Nothing
foreign import ccall "hb_font_get_glyph_origin_for_direction"
hb_font_get_glyph_origin_for_direction
:: Font_ -> Word32 -> Int -> Ptr Word32 -> Ptr Word32 -> IO ()
fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Word32, Word32)
fontGlyphOriginForDir font glyph dir = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
hb_font_get_glyph_origin_for_direction font' glyph (dir2int dir) x' y'
x <- peek x'
y <- peek y'
return (x, y)
foreign import ccall "hb_font_get_glyph_v_advance"
hb_font_get_glyph_v_advance :: Font_ -> Word32 -> Word32
fontGlyphVAdvance :: Font -> Word32 -> Word32
fontGlyphVAdvance = fontFunc hb_font_get_glyph_v_advance
foreign import ccall "hb_font_get_glyph_v_origin" hb_font_get_glyph_v_origin
:: Font_ -> Word32 -> Ptr Word32 -> Ptr Word32 -> IO Bool
fontGlyphVOrigin :: Font -> Word32 -> Maybe (Word32, Word32)
fontGlyphVOrigin font glyph = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
success <- hb_font_get_glyph_v_origin font' glyph x' y'
if success
then do
x <- peek x'
y <- peek y'
return $ Just (x, y)
else return Nothing
foreign import ccall "hb_font_get_nominal_glyph" hb_font_get_nominal_glyph
:: Font_ -> Char -> Ptr Word32 -> IO Bool
fontNominalGlyph :: Font -> Char -> Maybe Word32
fontNominalGlyph font char = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
success <- hb_font_get_nominal_glyph font' char ret
if success
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_ppem" hb_font_get_ppem
:: Font_ -> Ptr Int -> Ptr Int -> IO ()
fontPPEm :: Font -> (Int, Int)
fontPPEm font = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
hb_font_get_ppem font' x' y'
x_ppem <- peek x'
y_ppem <- peek y'
return (x_ppem, y_ppem)
foreign import ccall "hb_font_get_ptem" hb_font_get_ptem :: Font_ -> Float
fontPtEm :: Font -> Float
fontPtEm = fontFunc hb_font_get_ptem
foreign import ccall "hb_font_get_scale" hb_font_get_scale
:: Font_ -> Ptr Int -> Ptr Int -> IO ()
fontScale :: Font -> (Int, Int)
fontScale font = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
hb_font_get_scale font' x' y'
x <- peek x'
y <- peek y'
return (x, y)
foreign import ccall "hb_font_get_synthetic_slant" hb_font_get_synthetic_slant
:: Font_ -> Float
fontSynthSlant :: Font -> Float
fontSynthSlant = fontFunc hb_font_get_synthetic_slant
foreign import ccall "hb_font_get_variance_glyph" hb_font_get_variance_glyph
:: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
fontVarianceGlyph :: Font -> Word32 -> Word32 -> Maybe Word32
fontVarianceGlyph font glyph1 glyph2 = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
success <- hb_font_get_variance_glyph font' glyph1 glyph2 ret
if success
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_var_coords_design" hb_font_get_var_coords_design
:: Font_ -> Ptr Int -> IO (Ptr Float)
fontVarCoordsDesign :: Font -> [Float]
fontVarCoordsDesign font = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \length' -> do
arr <- hb_font_get_var_coords_design font' length'
length <- peek length'
forM [0..length-1] $ peekElemOff arr
foreign import ccall "hb_font_get_var_coords_normalized"
hb_font_get_var_coords_normalized :: Font_ -> Ptr Int -> IO (Ptr Int)
fontVarCoordsNormalized :: Font -> [Int]
fontVarCoordsNormalized font = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \length' -> do
arr <- hb_font_get_var_coords_normalized font' length'
length <- peek length'
forM [0..length-1] $ peekElemOff arr
foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string
:: Font_ -> Ptr Word8 -> Int -> Ptr Word32 -> IO Bool
fontTxt2Glyph :: Font -> ShortText -> Maybe Word32
fontTxt2Glyph font txt = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
let PS ptr offset size = toByteString txt
ok <- withForeignPtr ptr $ \ptr' ->
hb_font_glyph_from_string font' (plusPtr ptr' offset) (size - offset) ret
if ok
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_glyph_to_string" hb_font_glyph_to_string
:: Font_ -> Word32 -> CString -> Int -> IO ()
fontGlyph2Str :: Font -> Word32 -> Int -> String
fontGlyph2Str font glyph length = unsafePerformIO $
withForeignPtr font $ \font' -> allocaBytes length $ \ret -> do
hb_font_glyph_to_string font' glyph ret length
peekCString ret
---
data FontOptions = FontOptions {
optionPPEm :: Maybe (Int, Int),
optionPtEm :: Maybe Float,
optionScale :: Maybe (Int, Int),
optionSynthSlant :: Maybe Float
}
defaultFontOptions = FontOptions {
optionPPEm = Nothing, optionPtEm = Nothing,
optionScale = Nothing,
optionSynthSlant = Nothing
}
_setFontOptions font opts = do
case optionPPEm opts of
Just (x, y) -> hb_font_set_ppem font x y
Nothing -> return ()
case optionPtEm opts of
Just ptem -> hb_font_set_ptem font ptem
Nothing -> return ()
case optionScale opts of
Just (x, y) -> hb_font_set_scale font x y
Nothing -> return ()
case optionSynthSlant opts of
Just slant -> hb_font_set_synthetic_slant font slant
Nothing -> return ()
createFontWithOptions :: FontOptions -> Face -> Font
createFontWithOptions opts fce = unsafePerformIO $ do
font <- withForeignPtr fce $ hb_font_create
_setFontOptions font opts
hb_font_make_immutable font
newForeignPtr hb_font_destroy font
--ftCreateFontWithOptiosn :: FontOptions -> FT_Face -> Font
--ftCreateFontWithOptions opts fce = unsafePerformIO $ do
-- font <- hb_ft_font_create_referenced
-- _setFontOptions font opts
-- hb_font_make_immutable font
-- newForeignPtr hb_font_destroy font
foreign import ccall "hb_font_set_ppem" hb_font_set_ppem :: Font_ -> Int -> Int -> IO ()
foreign import ccall "hb_font_set_ptem" hb_font_set_ptem :: Font_ -> Float -> IO ()
foreign import ccall "hb_font_set_scale" hb_font_set_scale :: Font_ -> Int -> Int -> IO ()
foreign import ccall "hb_font_set_synthetic_slant" hb_font_set_synthetic_slant
:: Font_ -> Float -> IO ()
-- Defer implementation of other functions...
---
type Blob = ForeignPtr Blob'
data Blob'
type Blob_ = Ptr Blob'
foreign import ccall "hb_blob_create" hb_blob_create :: Ptr Word8 -> Int -> Int
-> StablePtr ByteString -> FunPtr (StablePtr ByteString -> IO ()) -> IO Blob_
hb_MEMORY_MODE_READONLY = 1
foreign import ccall "&hb_blob_destroy" hb_blob_destroy :: FunPtr (Blob_ -> IO ())
foreign import ccall "wrapper" hs_destructor
:: (StablePtr a -> IO ()) -> IO (FunPtr (StablePtr a -> IO ()))
bs2blob bytes@(PS ptr offset length) = do
bytes' <- newStablePtr bytes
destructor <- hs_destructor freeStablePtr
blob <- withForeignPtr ptr $ \ptr' ->
hb_blob_create (plusPtr ptr' offset) (length - offset)
hb_MEMORY_MODE_READONLY bytes' destructor
newForeignPtr hb_blob_destroy blob
faceFunc :: (Face_ -> a) -> (Face -> a)
faceFunc cb fce = unsafePerformIO $ withForeignPtr fce $ return . cb
fontFunc :: (Font_ -> a) -> (Font -> a)
fontFunc cb fnt = unsafePerformIO $ withForeignPtr fnt $ return . cb