{-# LANGUAGE DeriveGeneric #-}
module Data.Text.Glyphize.Font where
import Data.ByteString.Internal (ByteString(..))
import Data.ByteString (packCStringLen)
import Data.Word (Word8, Word32)
import Data.Int (Int32)
import FreeType.Core.Base (FT_Face, frSize)
import Data.Text.Glyphize.Buffer (tag_to_string, tag_from_string, Direction, dir2int)
import Control.Monad (forM, unless)
import Codec.Binary.UTF8.Light (w2c, c2w)
import Data.Maybe (fromMaybe)
import System.IO.Unsafe (unsafePerformIO)
import Foreign.ForeignPtr (ForeignPtr(..), withForeignPtr, newForeignPtr, newForeignPtr_)
import Foreign.Ptr (Ptr(..), FunPtr(..), nullPtr, nullFunPtr, castPtr)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Array (withArray, withArrayLen)
import Foreign.Storable (Storable(..))
import Foreign.Storable.Generic (GStorable(..))
import GHC.Generics (Generic(..))
import Foreign.C.String (CString, withCString, withCStringLen, peekCString, peekCStringLen)
data Feature = Feature {
featTag' :: Word32,
featValue :: Word32,
featStart :: Word,
featEnd :: Word
} deriving (Read, Show, Generic)
instance GStorable Feature
parseFeature :: String -> Maybe Feature
parseFeature str = unsafePerformIO $ withCStringLen str $ \(str', len) -> alloca $ \ret' -> do
success <- hb_feature_from_string str' len ret'
if success then Just <$> peek ret' else return Nothing
foreign import ccall "hb_feature_from_string" hb_feature_from_string
:: CString -> Int -> Ptr Feature -> IO Bool
unparseFeature :: Feature -> String
unparseFeature feature = unsafePerformIO $ alloca $ \feature' -> allocaBytes 128 $ \ret' -> do
feature' `poke` feature
hb_feature_to_string feature' ret' 128
peekCString ret'
foreign import ccall "hb_feature_to_string" hb_feature_to_string
:: Ptr Feature -> CString -> Word -> IO ()
data Variation = Variation {
varTag' :: Word32,
varValue :: Float
} deriving (Read, Show, Generic)
instance GStorable Variation
parseVariation :: String -> Maybe Variation
parseVariation str = unsafePerformIO $ withCStringLen str $ \(str', len) -> alloca $ \ret' -> do
success <- hb_variation_from_string str' len ret'
if success then Just <$> peek ret' else return Nothing
foreign import ccall "hb_variation_from_string" hb_variation_from_string
:: CString -> Int -> Ptr Variation -> IO Bool
unparseVariation var = unsafePerformIO $ alloca $ \var' -> allocaBytes 128 $ \ret' -> do
var' `poke` var
hb_variation_to_string var' ret' 128
peekCString ret'
foreign import ccall "hb_variation_to_string" hb_variation_to_string
:: Ptr Variation -> CString -> Word -> IO ()
featTag = tag_to_string . featTag'
varTag = tag_to_string . varTag'
globalStart, globalEnd :: Word
globalStart = 0
globalEnd = maxBound
countFace :: ByteString -> Word
countFace bytes = unsafePerformIO $ do
blob <- bs2blob bytes
withForeignPtr blob hb_face_count
foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Word
type Face = ForeignPtr Face'
type Face_ = Ptr Face'
data Face'
createFace :: ByteString -> Word -> Face
createFace bytes index = unsafePerformIO $ do
blob <- bs2blob bytes
face <- withForeignPtr blob $ flip hb_face_create index
hb_face_make_immutable face
newForeignPtr hb_face_destroy face
foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Word -> IO Face_
foreign import ccall "hb_face_make_immutable" hb_face_make_immutable :: Face_ -> IO ()
foreign import ccall "&hb_face_destroy" hb_face_destroy :: FunPtr (Face_ -> IO ())
ftCreateFace :: FT_Face -> IO Face
ftCreateFace = newForeignPtr hb_face_destroy . hb_ft_face_create_referenced
foreign import ccall "hb_ft_face_create_referenced" hb_ft_face_create_referenced
:: FT_Face -> Face_
emptyFace :: Face
emptyFace = unsafePerformIO $ newForeignPtr hb_face_destroy hb_face_get_empty
foreign import ccall "hb_face_get_empty" hb_face_get_empty :: Face_
faceTableTags :: Face -> Word -> Word -> (Word, [String])
faceTableTags fce offs cnt = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
alloca $ \cnt' -> allocaBytes (fromEnum cnt * 4) $ \arr' -> do
poke cnt' cnt
length <- hb_face_get_table_tags fce' offs cnt' arr'
cnt_ <- peek cnt'
arr <- forM [0..fromEnum cnt_-1] $ peekElemOff arr'
return (length, Prelude.map tag_to_string arr)
foreign import ccall "hb_face_get_table_tags" hb_face_get_table_tags
:: Face_ -> Word -> Ptr Word -> Ptr Word32 -> IO Word
faceGlyphCount :: Face -> Word
faceGlyphCount = faceFunc hb_face_get_glyph_count
foreign import ccall "hb_face_get_glyph_count" hb_face_get_glyph_count :: Face_ -> Word
faceCollectUnicodes :: Face -> [Word32]
faceCollectUnicodes = faceCollectFunc hb_face_collect_unicodes
foreign import ccall "hb_face_collect_unicodes" hb_face_collect_unicodes
:: Face_ -> Set_ -> IO ()
faceCollectVarSels :: Face -> [Word32]
faceCollectVarSels = faceCollectFunc hb_face_collect_variation_selectors
foreign import ccall "hb_face_collect_variation_selectors"
hb_face_collect_variation_selectors :: Face_ -> Set_ -> IO ()
faceCollectVarUnicodes :: Face -> Word32 -> [Word32]
faceCollectVarUnicodes fce varSel = (faceCollectFunc inner) fce
where inner a b = hb_face_collect_variation_unicodes a varSel b
foreign import ccall "hb_face_collect_variation_unicodes"
hb_face_collect_variation_unicodes :: Face_ -> Word32 -> Set_ -> IO ()
faceIndex :: Face -> Word
faceIndex = faceFunc hb_face_get_index
foreign import ccall "hb_face_get_index" hb_face_get_index :: Face_ -> Word
faceUpem :: Face -> Word
faceUpem = faceFunc hb_face_get_upem
foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Word
faceBlob :: Face -> ByteString
faceBlob = blob2bs . faceFunc hb_face_reference_blob
foreign import ccall "hb_face_reference_blob" hb_face_reference_blob :: Face_ -> Blob_
faceTable :: Face -> String -> ByteString
faceTable face tag = blob2bs $ unsafePerformIO $ withForeignPtr face $ \fce' -> do
hb_face_reference_table fce' $ tag_from_string tag
foreign import ccall "hb_face_reference_table" hb_face_reference_table :: Face_ -> Word32 -> IO Blob_
data FaceOptions = FaceOptions {
faceOptGlyphCount :: Maybe Int,
faceOptIndex :: Maybe Word,
faceOptUPEm :: Maybe Word
}
defaultFaceOptions = FaceOptions Nothing Nothing Nothing
_setFaceOptions face opts = do
case faceOptGlyphCount opts of
Just x -> hb_face_set_glyph_count face x
Nothing -> return ()
case faceOptIndex opts of
Just x -> hb_face_set_index face x
Nothing -> return ()
case faceOptUPEm opts of
Just x -> hb_face_set_upem face x
Nothing -> return ()
foreign import ccall "hb_face_set_glyph_count" hb_face_set_glyph_count
:: Face_ -> Int -> IO ()
foreign import ccall "hb_face_set_index" hb_face_set_index :: Face_ -> Word -> IO ()
foreign import ccall "hb_face_set_upem" hb_face_set_upem :: Face_ -> Word -> IO ()
createFaceWithOpts :: FaceOptions -> ByteString -> Word -> Face
createFaceWithOpts opts bytes index = unsafePerformIO $ do
blob <- bs2blob bytes
face <- withForeignPtr blob $ flip hb_face_create index
_setFaceOptions face opts
hb_face_make_immutable face
newForeignPtr hb_face_destroy face
ftCreateFaceWithOpts :: FaceOptions -> FT_Face -> IO Face
ftCreateFaceWithOpts opts ftFace = do
let face = hb_ft_face_create_referenced ftFace
_setFaceOptions face opts
hb_face_make_immutable face
newForeignPtr hb_face_destroy face
buildFace :: [(String, ByteString)] -> FaceOptions -> Face
buildFace tables opts = unsafePerformIO $ do
builder <- hb_face_builder_create
forM tables $ \(tag, bytes) -> do
blob <- bs2blob bytes
withForeignPtr blob $ hb_face_builder_add_table builder $ tag_from_string tag
_setFaceOptions builder opts
hb_face_make_immutable builder
newForeignPtr hb_face_destroy builder
foreign import ccall "hb_face_builder_create" hb_face_builder_create :: IO Face_
foreign import ccall "hb_face_builder_add_table" hb_face_builder_add_table
:: Face_ -> Word32 -> Blob_ -> IO Bool
type Font = ForeignPtr Font'
type Font_ = Ptr Font'
data Font'
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_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 ())
ftCreateFont :: FT_Face -> IO Font
ftCreateFont fce = do
font <- hb_ft_font_create_referenced fce
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 Font_
createSubFont :: Font -> Font
createSubFont parent = unsafePerformIO $ do
font <- withForeignPtr parent $ hb_font_create_sub_font
hb_font_make_immutable font
newForeignPtr hb_font_destroy font
foreign import ccall "hb_font_create_sub_font" hb_font_create_sub_font :: Font_ -> IO Font_
emptyFont :: Font
emptyFont = unsafePerformIO $ newForeignPtr hb_font_destroy hb_font_get_empty
foreign import ccall "hb_font_get_empty" hb_font_get_empty :: Font_
fontFace :: Font -> Face
fontFace font = unsafePerformIO $ withForeignPtr font $ \font' -> do
face' <- hb_font_get_face font'
newForeignPtr_ face'
foreign import ccall "hb_font_get_face" hb_font_get_face :: Font_ -> IO Face_
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" hb_font_get_glyph
:: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
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_advance_for_direction"
hb_font_get_glyph_advance_for_direction
:: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO ()
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" hb_font_get_glyph_contour_point
:: Font_ -> Word32 -> 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
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
data GlyphExtents = GlyphExtents {
xBearing :: Word32,
yBearing :: Word32,
width :: Word32,
height :: Word32
} deriving (Generic)
instance GStorable GlyphExtents
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" hb_font_get_glyph_extents
:: Font_ -> Word32 -> 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_extents_for_origin"
hb_font_get_glyph_extents_for_origin
:: Font_ -> Word32 -> Int -> Ptr GlyphExtents -> IO Bool
fontGlyphFromName :: Font -> String -> Maybe Word32
fontGlyphFromName font name = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
success <- withCStringLen name $ \(name', len) ->
hb_font_get_glyph_from_name font' name' len ret
if success
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_glyph_from_name" hb_font_get_glyph_from_name
:: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
fontGlyphHAdvance :: Font -> Word32 -> Int32
fontGlyphHAdvance = fontFunc hb_font_get_glyph_h_advance
foreign import ccall "hb_font_get_glyph_h_advance" hb_font_get_glyph_h_advance
:: Font_ -> Word32 -> Int32
fontGlyphVAdvance :: Font -> Word32 -> Int32
fontGlyphVAdvance = fontFunc hb_font_get_glyph_v_advance
foreign import ccall "hb_font_get_glyph_v_advance" hb_font_get_glyph_v_advance
:: Font_ -> Word32 -> Int32
fontGlyphHKerning :: Font -> Word32 -> Word32 -> Int32
fontGlyphHKerning = fontFunc hb_font_get_glyph_h_kerning
foreign import ccall "hb_font_get_glyph_h_kerning" hb_font_get_glyph_h_kerning
:: Font_ -> Word32 -> Word32 -> Int32
fontGlyphHOrigin :: Font -> Word32 -> Maybe (Int32, Int32)
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_h_origin" hb_font_get_glyph_h_origin ::
Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphVOrigin :: Font -> Word32 -> Maybe (Int32, Int32)
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_glyph_v_origin" hb_font_get_glyph_v_origin ::
Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Int32, Int32)
fontGlyphKerningForDir font a b dir = unsafePerformIO $ withForeignPtr font $ \font' ->
alloca $ \x' -> alloca $ \y' -> do
hb_font_get_glyph_kerning_for_direction font' a b (dir2int dir) x' y'
x <- peek x'
y <- peek y'
return (x, y)
foreign import ccall "hb_font_get_glyph_kerning_for_direction"
hb_font_get_glyph_kerning_for_direction ::
Font_ -> Word32 -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO ()
fontGlyphName :: Font -> Word32 -> Maybe String
fontGlyphName a b = fontGlyphName_ a b 32
fontGlyphName_ :: Font -> Word32 -> Int -> Maybe String
fontGlyphName_ font glyph size = unsafePerformIO $ withForeignPtr font $ \font' ->
allocaBytes size $ \name' -> do
success <- hb_font_get_glyph_name font' glyph name' (toEnum size)
if success
then Just <$> peekCStringLen (name', size)
else return Nothing
foreign import ccall "hb_font_get_glyph_name" hb_font_get_glyph_name ::
Font_ -> Word32 -> CString -> Word32 -> IO Bool
fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Int32, Int32)
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_origin_for_direction"
hb_font_get_glyph_origin_for_direction ::
Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO ()
fontNominalGlyph :: Font -> Char -> Maybe Word32
fontNominalGlyph font c =
unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do
success <- hb_font_get_nominal_glyph font' (c2w c) glyph'
if success then Just <$> peek glyph' else return Nothing
foreign import ccall "hb_font_get_nominal_glyph" hb_font_get_nominal_glyph ::
Font_ -> Word32 -> Ptr Word32 -> IO Bool
fontParent :: Font -> Font
fontParent child =
unsafePerformIO (newForeignPtr_ =<< withForeignPtr child hb_font_get_parent)
foreign import ccall "hb_font_get_parent" hb_font_get_parent :: Font_ -> IO Font_
fontPPEm :: Font -> (Word32, Word32)
fontPPEm font =
unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
hb_font_get_ppem font' x' y'
x <- peek x'
y <- peek y'
return (x, y)
foreign import ccall "hb_font_get_ppem" hb_font_get_ppem ::
Font_ -> Ptr Word32 -> Ptr Word32 -> IO ()
fontPtEm :: Font -> Float
fontPtEm = fontFunc hb_font_get_ptem
foreign import ccall "hb_font_get_ptem" hb_font_get_ptem :: Font_ -> Float
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_scale" hb_font_get_scale
:: Font_ -> Ptr Int -> Ptr Int -> IO ()
fontVarGlyph :: Font -> Word32 -> Word32 -> Maybe Word32
fontVarGlyph font unicode varSel = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \glyph' -> do
success <- hb_font_get_variation_glyph font' unicode varSel glyph'
if success
then return . Just =<< peek glyph'
else return Nothing
foreign import ccall "hb_font_get_variation_glyph" hb_font_get_variation_glyph
:: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
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..fromEnum length-1] $ peekElemOff arr
foreign import ccall "hb_font_get_var_coords_normalized"
hb_font_get_var_coords_normalized :: Font_ -> Ptr Word -> IO (Ptr Int)
fontTxt2Glyph :: Font -> String -> Maybe Word32
fontTxt2Glyph font str = unsafePerformIO $
withForeignPtr font $ \font' -> alloca $ \ret -> do
ok <- withCStringLen str $ \(str', len) ->
hb_font_glyph_from_string font' str' len ret
if ok
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string
:: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
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
foreign import ccall "hb_font_glyph_to_string" hb_font_glyph_to_string
:: Font_ -> Word32 -> CString -> Int -> IO ()
data FontExtents = FontExtents {
ascender :: Int32,
descender :: Int32,
lineGap :: Int32
} deriving (Generic)
instance GStorable FontExtents
fontExtentsForDir :: Font -> Maybe Direction -> FontExtents
fontExtentsForDir font dir = unsafePerformIO $ alloca $ \ret -> do
withForeignPtr font $ \font' ->
hb_font_get_extents_for_direction font' (dir2int dir) ret
peek ret
foreign import ccall "hb_font_get_extents_for_direction"
hb_font_get_extents_for_direction :: Font_ -> Int -> Ptr FontExtents -> IO ()
fontHExtents font = unsafePerformIO $ alloca $ \ret -> do
ok <- withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret
if ok
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_h_extents" hb_font_get_h_extents
:: Font_ -> Ptr FontExtents -> IO Bool
fontVExtents font = unsafePerformIO $ alloca $ \ret -> do
ok <- withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret
if ok
then return . Just =<< peek ret
else return Nothing
foreign import ccall "hb_font_get_v_extents" hb_font_get_v_extents
:: Font_ -> Ptr FontExtents -> IO Bool
data FontOptions = FontOptions {
optionPPEm :: Maybe (Word, Word),
optionPtEm :: Maybe Float,
optionScale :: Maybe (Int, Int),
optionFace :: Maybe Face,
optionParent :: Maybe Font,
optionVariations :: [Variation],
optionVarCoordsDesign :: [Float],
optionVarCoordsNormalized :: [Int],
optionVarNamedInstance :: Maybe Word
}
defaultFontOptions = FontOptions {
optionPPEm = Nothing, optionPtEm = Nothing, optionScale = Nothing,
optionFace = Nothing, optionParent = Nothing,
optionVariations = [], optionVarCoordsDesign = [], optionVarCoordsNormalized = [],
optionVarNamedInstance = 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 optionFace opts of
Just face -> withForeignPtr face $ hb_font_set_face font
Nothing -> return ()
case optionParent opts of
Just parent -> withForeignPtr parent $ hb_font_set_parent font
Nothing -> return ()
unless (null $ optionVariations opts) $
withArrayLen (optionVariations opts) $ \len vars ->
hb_font_set_variations font vars $ toEnum len
unless (null $ optionVarCoordsDesign opts) $
withArrayLen (optionVarCoordsDesign opts) $ \len coords ->
hb_font_set_var_coords_design font coords $ toEnum len
unless (null $ optionVarCoordsNormalized opts) $
withArrayLen (optionVarCoordsNormalized opts) $ \len coords ->
hb_font_set_var_coords_normalized font coords $ toEnum len
case optionVarNamedInstance opts of
Just inst -> hb_font_set_var_named_instance font inst
Nothing -> return ()
foreign import ccall "hb_font_set_ppem" hb_font_set_ppem :: Font_ -> Word -> Word -> 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_face" hb_font_set_face :: Font_ -> Face_ -> IO ()
foreign import ccall "hb_font_set_parent" hb_font_set_parent :: Font_ -> Font_ -> IO ()
foreign import ccall "hb_font_set_variations" hb_font_set_variations ::
Font_ -> Ptr Variation -> Word -> IO ()
foreign import ccall "hb_font_set_var_coords_design" hb_font_set_var_coords_design ::
Font_ -> Ptr Float -> Word -> IO ()
foreign import ccall "hb_font_set_var_coords_normalized"
hb_font_set_var_coords_normalized :: Font_ -> Ptr Int -> Word -> IO ()
foreign import ccall "hb_font_set_var_named_instance" hb_font_set_var_named_instance ::
Font_ -> Word -> IO ()
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
ftCreateFontWithOptions :: FontOptions -> FT_Face -> Font
ftCreateFontWithOptions opts fce = unsafePerformIO $ do
font <- hb_ft_font_create_referenced fce
_setFontOptions font opts
hb_font_make_immutable font
newForeignPtr hb_font_destroy font
createSubFontWithOptions :: FontOptions -> Font -> Font
createSubFontWithOptions opts font = unsafePerformIO $ do
font <- withForeignPtr font $ hb_font_create_sub_font
_setFontOptions font opts
hb_font_make_immutable font
newForeignPtr hb_font_destroy font
type Blob = ForeignPtr Blob'
data Blob'
type Blob_ = Ptr Blob'
bs2blob :: ByteString -> IO Blob
bs2blob (BS bytes len) = do
blob <- withForeignPtr bytes $ \bytes' ->
hb_blob_create bytes' len hb_MEMORY_MODE_DUPLICATE nullPtr nullFunPtr
newForeignPtr hb_blob_destroy blob
foreign import ccall "hb_blob_create" hb_blob_create ::
Ptr Word8 -> Int -> Int -> Ptr () -> FunPtr (Ptr () -> IO ()) -> IO Blob_
hb_MEMORY_MODE_DUPLICATE = 0
foreign import ccall "&hb_blob_destroy" hb_blob_destroy :: FunPtr (Blob_ -> IO ())
blob2bs :: Blob_ -> ByteString
blob2bs blob = unsafePerformIO $ alloca $ \length' -> do
dat <- hb_blob_get_data blob length'
length <- peek length'
ret <- packCStringLen (dat, fromIntegral length)
hb_blob_destroy' blob
return ret
foreign import ccall "hb_blob_get_data" hb_blob_get_data :: Blob_ -> Ptr Word -> IO CString
foreign import ccall "hb_blob_destroy" hb_blob_destroy' :: Blob_ -> IO ()
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
faceCollectFunc :: (Face_ -> Set_ -> IO ()) -> (Face -> [Word32])
faceCollectFunc cb fce = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
set <- createSet
withForeignPtr set $ cb fce'
set2list set
data Set'
type Set = ForeignPtr Set'
type Set_ = Ptr Set'
createSet :: IO Set
createSet = do
ret <- hb_set_create
newForeignPtr hb_set_destroy ret
foreign import ccall "hb_set_create" hb_set_create :: IO Set_
foreign import ccall "&hb_set_destroy" hb_set_destroy :: FunPtr (Set_ -> IO ())
setNext :: Set -> Word32 -> Maybe Word32
setNext set iter = unsafePerformIO $ withForeignPtr set $ \set' -> alloca $ \iter' -> do
poke iter' iter
success <- hb_set_next set' iter'
if success
then return . Just =<< peek iter'
else return Nothing
foreign import ccall "hb_set_next" hb_set_next :: Set_ -> Ptr Word32 -> IO Bool
set2list :: Set -> IO [Word32]
set2list set = return $ inner maxBound
where
inner iter | Just x <- setNext set iter = x : inner x
| otherwise = []