~alcinnz/harfbuzz-pure

c0f7026e02b7b05748fb108b69da7de4d7758d21 — Adrian Cochrane 1 year, 5 months ago d574562 
Fix segfaults & include test assets (major refactor).
patch browse 
12 files changed, 744 insertions(+), 560 deletions(-)

M Data/Text/Glyphize.hs
M Data/Text/Glyphize/Buffer.hs
M Data/Text/Glyphize/Font.hs
M Main.hs
A assets/Lora-Bold.ttf
A assets/Lora-BoldItalic.ttf
A assets/Lora-Italic.ttf
A assets/Lora-Regular.ttf
A assets/Neuton-Regular.ttf
A assets/OFL.txt
A assets/SIL Open Font License.txt
M harfbuzz-pure.cabal

M Data/Text/Glyphize.hs => Data/Text/Glyphize.hs +41 -65
@@ 1,75 1,51 @@
module Data.Text.Glyphize where
module Data.Text.Glyphize (shape, version, versionAtLeast, versionString,

import Data.Text.Glyphize.Buffer
import Data.Text.Glyphize.Font

import Data.Word

import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.C.String
import Control.Monad (forM)
import Control.Concurrent.QSem
import System.IO.Unsafe (unsafePerformIO)
    Buffer(..), ContentType(..), ClusterLevel(..), Direction(..), defaultBuffer,
    dirFromStr, dirToStr, dirReverse, dirBackward, dirForward, dirHorizontal, dirVertical,
    scriptHorizontalDir, languageDefault, tag_from_string, tag_to_string, guessSegmentProperties,

foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer_ -> Ptr Feature -> Int -> IO ()
    GlyphInfo(..), GlyphPos(..), Feature(..), featTag, Variation(..), varTag,
    parseFeature, unparseFeature, parseVariation, unparseVariation, globalStart, globalEnd,

-- | Compute which glyphs from the provided font should be rendered where to
-- depict the given buffer of text.
shape :: Font -> Buffer -> [(GlyphInfo, GlyphPos)]
shape font buf = shapeWithFeatures font buf []
    countFace, Face, createFace, ftCreateFace, emptyFace, faceTableTags, faceGlyphCount,
    faceCollectUnicodes, faceCollectVarSels, faceCollectVarUnicodes, faceIndex, faceUpem,
    faceBlob, faceTable,

-- FIXME Certain input text can trigger a segfault. I'm not sure how to debug this.
-- Thought for a moment I fixed it with a semaphore
-- (seems related to number of threads), but appears not...
    Font, createFont, ftCreateFont, emptyFont, fontFace, fontGlyph, fontGlyphAdvance,
    fontGlyphContourPoint, fontGlyphContourPointForOrigin, fontGlyphFromName,
    fontGlyphHAdvance, fontGlyphVAdvance, fontGlyphHKerning, fontGlyphHOrigin, fontGlyphVOrigin,
    fontGlyphKerningForDir, fontGlyphName, fontGlyphName_, fontGlyphOriginForDir,
    fontNominalGlyph, fontPPEm, fontPtEm, fontScale, fontVarGlyph, -- fontSyntheticSlant,
    fontVarCoordsNormalized, fontTxt2Glyph, fontGlyph2Str, -- fontVarCoordsDesign,

data Feature = Feature {
    tag :: String,
    value :: Word32,
    start :: Word,
    end :: Word
}
instance Storable Feature where
    sizeOf _ = sizeOf (undefined :: Word32) * 2 + sizeOf (undefined :: Word) * 2
    alignment _ = alignment (undefined :: Word32)
    peek p = do
        let q = castPtr p
        tag' <- peek q
        val' <- peekElemOff q 1
        let r = castPtr $ plusPtr p (sizeOf (undefined :: Word32) * 2)
        start' <- peek r
        end' <- peekElemOff r 1
        return $ Feature (hb_tag_to_string tag') val' start' end'
    GlyphExtents(..), fontGlyphExtents, fontGlyphExtentsForOrigin,
    FontExtents(..), fontExtentsForDir, fontHExtents, fontVExtents,
    FontOptions(..), defaultFontOptions, createFontWithOptions, ftCreateFontWithOptions, 
    ) where

    poke p (Feature tag' val' start' end') = do
        let q = castPtr p
        poke q $ hb_tag_from_string tag'
        pokeElemOff q 1 val'
        let r = castPtr $ plusPtr p (sizeOf (undefined :: Word32) * 2)
        poke r start'
        pokeElemOff r 1 end'

-- | Variant of `shape` specifying OpenType features to apply.
-- If two features have the same tag but overlapping ranges, the one with a
-- higher index takes precedance.
shapeWithFeatures :: Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)]
shapeWithFeatures font buf feats = unsafePerformIO $ do
    waitQSem shapingSem
    buf_ <- freeze' buf
    allocaBytes (sizeOf (undefined :: Feature) * length feats) $ \arr' -> do
        forM (zip [0..] feats) $ \(i, feat) -> pokeElemOff arr' i feat
        withForeignPtr font $ \font' -> withForeignPtr buf_ $ \buf' ->
            hb_shape font' buf' arr' $ length feats
    infos <- glyphInfos' buf_
    pos <- glyphsPos' buf_
    signalQSem shapingSem
    return $ zip infos pos
import Data.Text.Glyphize.Font
import Data.Text.Glyphize.Buffer

-- | Used to avoid segfaults...
{-# NOINLINE shapingSem #-}
shapingSem = unsafePerformIO $ newQSem 25
import System.IO.Unsafe (unsafePerformIO)
import Foreign.Ptr (Ptr(..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Storable (peek)

import Foreign.C.String (CString(..), peekCString)
import Foreign.Marshal.Array (withArrayLen)

shape :: Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)]
shape font buffer features = unsafePerformIO $ withForeignPtr font $ \font' ->
    withBuffer buffer $ \buffer' -> withArrayLen features $ \len features' -> do
        hb_shape font' buffer' features' $ toEnum len
        infos <- glyphInfos buffer'
        pos <- glyphsPos buffer'
        return $ zip infos pos
foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer' -> Ptr Feature -> Word -> IO ()

guessSegmentProperties :: Buffer -> Buffer
guessSegmentProperties = unsafePerformIO . flip withBuffer thawBuffer

foreign import ccall "hb_version" hb_version :: Ptr Int -> Ptr Int -> Ptr Int -> IO ()
version :: (Int, Int, Int)


M Data/Text/Glyphize/Buffer.hs => Data/Text/Glyphize/Buffer.hs +270 -254
@@ 1,31 1,36 @@
{-# LANGUAGE MagicHash, UnliftedFFITypes, DeriveGeneric #-}
module Data.Text.Glyphize.Buffer where

import Data.Text.Lazy as Lazy hiding (toUpper, toLower)
import Data.ByteString.Lazy as Lazy hiding (toUpper, toLower)
import Data.ByteString.Lazy as LBS
import Data.Int
import qualified Data.Text.Internal.Lazy as Lazy
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Internal as Txt
import Data.Char (toUpper, toLower)
import Control.Monad (forM)

import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.C.Types
import Foreign.C.String
import Data.Word
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
--- To fill computed text property.
import Data.Text.Encoding (decodeUtf8Lenient)
import Codec.Binary.UTF8.Light (encodeUTF8, w2c, c2w)

import Data.Text.Lazy.Encoding
import Data.ByteString.Lazy.Internal as Lazy
import Data.ByteString.Internal as Strict hiding (w2c, c2w)
import Data.ByteString.Short.Internal as Strict hiding (w2c, c2w)
import qualified Data.Text.Array as A
import GHC.Exts (ByteArray#, sizeofByteArray#, Int#)
import Data.Word (Word32)
import Data.Int (Int32)
import Data.Bits ((.|.), (.&.), shiftR, shiftL, testBit)
import Data.Char (ord, chr, toUpper, toLower)

import Control.Monad (forM)
import Codec.Binary.UTF8.Light (encodeUTF8, w2c, c2w)
import System.IO.Unsafe (unsafePerformIO)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Ptr
import Foreign.C.String (CString, withCString, peekCString)
import Foreign.Storable (Storable(..))
import GHC.Generics (Generic(..))
import Foreign.Storable.Generic (GStorable(..))

------
--- Public Datastructures
------

data Buffer = Buffer {
    text :: Either Lazy.Text Lazy.ByteString,
    text :: Lazy.Text,
    -- ^ The Unicode text, in visual order, for HarfBuzz to convert into glyphs.
    contentType :: Maybe ContentType,
    -- ^ What the bytes of the ByteString contents represents,


@@ 65,7 70,7 @@ data Buffer = Buffer {
    -- the space glyph and zeroing the advance width.)
    don'tInsertDottedCircle :: Bool,
    -- ^ a dotted circle should not be inserted in the rendering of incorrect
    -- character sequences (such at <0905 093E>).
    -- character sequences (such as <0905 093E>).
    clusterLevel :: ClusterLevel,
    -- ^ dictates one aspect of how HarfBuzz will treat non-base characters
    -- during shaping.


@@ 73,14 78,20 @@ data Buffer = Buffer {
    -- ^ The glyph number that replaces invisible characters in the
    -- shaping result. If set to zero (default), the glyph for the U+0020
    -- SPACE character is used. Otherwise, this value is used verbatim.
    replacementCodepoint :: Char
    -- ^ the hb_codepoint_t that replaces invalid entries for a given encoding
    -- when adding text to buffer .
} deriving (Eq, Show, Read)
    replacementCodepoint :: Char,
    -- ^ the glyph number that replaces invalid entries for a given encoding
    -- when adding text to buffer.
    notFoundGlyph :: Char
    -- ^ the glyph number that replaces replaces characters not found in the font.
  } deriving (Eq, Show, Read, Ord)

data ContentType = ContentTypeUnicode | ContentTypeGlyphs deriving (Eq, Show, Read, Ord)
data ClusterLevel = ClusterMonotoneGraphemes | ClusterMonotoneChars | ClusterChars
    deriving (Eq, Show, Read, Ord)

-- | An empty buffer with sensible default properties.
defaultBuffer = Buffer {
        text = Right LBS.empty,
        text = Lazy.empty,
        contentType = Just ContentTypeUnicode,
        direction = Nothing,
        script = Nothing,


@@ 91,87 102,28 @@ defaultBuffer = Buffer {
        removeDefaultIgnorables = False,
        don'tInsertDottedCircle = False,
        clusterLevel = ClusterMonotoneGraphemes,
        invisibleGlyph = '\0',
        replacementCodepoint = '\xFFFD'
        invisibleGlyph = ' ',
        replacementCodepoint = '\xFFFD',
        notFoundGlyph = '\0'
    }

data ContentType = ContentTypeUnicode | ContentTypeGlyphs deriving (Eq, Show, Read)
data Direction = DirLTR | DirRTL | DirTTB | DirBTT deriving (Eq, Show, Read)
data ClusterLevel = ClusterMonotoneGraphemes | ClusterMonotoneChars | ClusterChars deriving (Eq, Show, Read)

data GlyphInfo = GlyphInfo {
    codepoint :: Word32,
    -- ^ Glyph index (or unicode codepoint)
    cluster :: Word32
    -- ^ The index of the character in the original text that corresponds to
    -- this `GlyphInfo`. More than one `GlyphInfo` may have the same `cluster`
    -- value if they resulted from the same character, & when more than one
    -- character gets merged into the same glyph `GlyphInfo` will have the
    -- smallest cluster value of them.
    -- By default some characters are merged into the same cluster even when
    -- they are seperate glyphs, `Buffer`'s `clusterLevel` property allows
    -- selecting more fine grained cluster handling.
} deriving (Show, Read, Eq)
instance Storable GlyphInfo where
    sizeOf _ = 2 * sizeOf (undefined :: Word32)
    alignment _ = alignment (undefined :: Word32)
    peek p = do
        codepoint' <- peek $ castPtr p
        cluster' <- peekElemOff (castPtr p) 1
        return $ GlyphInfo codepoint' cluster'
    poke p (GlyphInfo a b) = do
        q <- return $ castPtr p
        poke q a
        pokeElemOff q 1 b

data GlyphPos = GlyphPos {
    x_advance :: Int32,
    -- ^ How much the line advances after drawing this glyph when setting text
    -- in horizontal direction.
    y_advance :: Int32,
    -- ^ How much the line advances after drawing this glyph when setting text
    -- in vertical direction.
    x_offset :: Int32,
    -- ^ How much the glyph moves on the X-axis before drawing it, this should
    -- not effect how much the line advances.
    y_offset :: Int32
    -- ^ How much the glyph moves on the Y-axis before drawing it, this should
    -- not effect how much the line advances.
} deriving (Show, Read, Eq)
instance Storable GlyphPos where
    sizeOf _ = 4 * sizeOf (undefined :: Int32)
    alignment _ = alignment (undefined :: Int32)
    peek p = do
        q <- return $ castPtr p
        xa <- peek q
        ya <- peekElemOff q 1
        xoff <- peekElemOff q 2
        yoff <- peekElemOff q 3
        return $ GlyphPos xa ya xoff yoff
    poke p (GlyphPos xa ya xoff yoff) = do
        q <- return $ castPtr p
        poke q xa
        pokeElemOff q 1 ya
        pokeElemOff q 2 xoff
        pokeElemOff q 3 yoff

guessSegmentProperties :: Buffer -> Buffer
guessSegmentProperties = thaw . freeze
scriptHorizontalDir :: String -> Maybe Direction
scriptHorizontalDir script =
    int2dir $ hb_script_get_horizontal_direction $ hb_script_from_string script

int2dir 4 = Just DirLTR
int2dir 5 = Just DirRTL
int2dir 6 = Just DirTTB
int2dir 7 = Just DirBTT
int2dir _ = Nothing
dir2int Nothing = 0
dir2int (Just DirLTR) = 4
dir2int (Just DirRTL) = 5
dir2int (Just DirTTB) = 6
dir2int (Just DirBTT) = 7
------
--- Directions
------

data Direction = DirLTR | DirRTL | DirTTB | DirBTT deriving (Eq, Show, Read, Ord)
dirFromStr ('L':_) = DirLTR
dirFromStr ('l':_) = DirLTR
dirFromStr ('R':_) = DirRTL
dirFromStr ('r':_) = DirRTL
dirFromStr ('T':_) = DirTTB
dirFromStr ('t':_) = DirTTB
dirFromStr ('B':_) = DirBTT
dirFromStr ('b':_) = DirBTT
dirToStr DirLTR = "ltr"
dirToStr DirRTL = "rtl"
dirToStr DirTTB = "ttb"
dirToStr DirBTT = "btt"
dirReverse DirLTR = DirRTL
dirReverse DirRTL = DirLTR
dirReverse DirTTB = DirBTT


@@ 181,103 133,240 @@ dirForward dir = dir `Prelude.elem` [DirLTR, DirTTB]
dirHorizontal dir = dir `Prelude.elem` [DirLTR, DirRTL]
dirVertical dir = dir `Prelude.elem` [DirTTB, DirBTT]

---
dir2int Nothing = 0
dir2int (Just DirLTR) = 4
dir2int (Just DirRTL) = 5
dir2int (Just DirTTB) = 6
dir2int (Just DirBTT) = 7
foreign import ccall "hb_buffer_set_direction" hb_buffer_set_direction
    :: Buffer' -> Int -> IO ()

int2dir 4 = Just DirLTR
int2dir 5 = Just DirRTL
int2dir 6 = Just DirTTB
int2dir 7 = Just DirBTT
int2dir _ = Nothing

scriptHorizontalDir :: String -> Maybe Direction
scriptHorizontalDir = int2dir . hb_script_get_horizontal_direction . script_from_string
foreign import ccall "hb_script_get_horizontal_direction" hb_script_get_horizontal_direction
    :: Word32 -> Int

------
--- Locales
------
data Language'
type Language = Ptr Language'
languageDefault :: IO String
languageDefault = hb_language_get_default >>= hb_language_to_string >>= peekCString
foreign import ccall "hb_language_to_string" hb_language_to_string :: Language -> IO CString
foreign import ccall "hb_language_get_default" hb_language_get_default :: IO Language

foreign import ccall "hb_language_from_string" hb_language_from_string'
    :: CString -> Int -> IO Language
hb_language_from_string :: String -> IO Language
hb_language_from_string str =
    withCString str $ \str' -> hb_language_from_string' str' (-1)

{-languageMatches :: String -> String -> Bool
languageMatches lang specific = unsafePerformIO $ do
    lang' <- hb_language_from_string lang
    specific' <- hb_language_from_string specific
    hb_language_matches lang' specific'
foreign import ccall "hb_language_matches" hb_language_matches :: Language -> Language -> IO Bool-}

------
--- FFI Support
------

type Buffer' = ForeignPtr Buffer''
data Buffer''
type Buffer_ = Ptr Buffer''
type Buffer' = Ptr Buffer''

withNewBuffer :: (Buffer' -> IO a) -> IO a
withNewBuffer cb = do
    buf <- hb_buffer_create
    ret <- cb buf
    hb_buffer_destroy buf
    return ret
foreign import ccall "hb_buffer_create" hb_buffer_create :: IO Buffer'
foreign import ccall "hb_buffer_destroy" hb_buffer_destroy :: Buffer' -> IO ()

{-txt2primitiveArray (A.ByteArray arr') = ByteArray arr'
withByteArrayLen :: ByteArray -> (CString -> Int -> IO a) -> IO a
withByteArrayLen arr cb = let len = sizeofByteArray arr in allocaBytes len $ \arr' -> do
    copyByteArrayToPtr arr' arr 0 len
    cb arr' len-}
bufferWithText _ Lazy.Empty cb = cb
bufferWithText buffer txt@(Lazy.Chunk (Txt.Text (A.ByteArray arr) offset length) txts) cb = do
    hb_buffer_add_utf8 buffer arr (sizeofByteArray# arr) (toEnum offset) length
    bufferWithText buffer txts cb
foreign import ccall "hb_buffer_add_utf8" hb_buffer_add_utf8
    :: Buffer' -> ByteArray# -> Int# -> Word -> Int -> IO ()

titlecase :: String -> String
titlecase "" = ""
titlecase (c:cs) = toUpper c : Prelude.map toLower cs
script_from_string str = tag_from_string $ case titlecase str of
    'Q':'a':'a':'i':_ -> "Zinh"
    'Q':'a':'a':'c':_ -> "Copt"

    'A':'r':'a':'n':_ -> "Arab"
    'C':'y':'r':'s':_ -> "Cyrl"
    'G':'e':'o':'k':_ -> "Geor"
    'H':'a':'n':'s':_ -> "Hani"
    'H':'a':'n':'t':_ -> "Hani"
    'J':'a':'m':'o':_ -> "Hang"
    'L':'a':'t':'f':_ -> "Latn"
    'L':'a':'t':'g':_ -> "Latn"
    'S':'y':'r':'e':_ -> "Syrc"
    'S':'y':'r':'j':_ -> "Syrc"
    'S':'y':'r':'n':_ -> "Syrc"
    x -> x
tag_from_string :: String -> Word32
tag_from_string str = case str ++ Prelude.repeat '\0' of
    c1:c2:c3:c4:_ -> Prelude.foldl (.|.) 0 [
        shiftL (c2w c1 .&. 0x7) 24,
        shiftL (c2w c2 .&. 0x7) 16,
        shiftL (c2w c3 .&. 0x7) 8,
        shiftL (c2w c4 .&. 0x7) 0
      ]
    _ -> 0
tag_to_string :: Word32 -> String
tag_to_string tag = [
    w2c (shiftR tag 24 .&. 0x7),
    w2c (shiftR tag 16 .&. 0x7),
    w2c (shiftR tag 8 .&. 0x7),
    w2c (shiftR tag 0 .&. 0x7)
  ]

------
--- Haskell-to-C conversion
------

-- | Converts from a Haskell `Buffer` representation into a C representation used internally.
freeze = unsafePerformIO . freeze'
-- | Variant of `freeze` for use in IO code.
freeze' buf = do
    buffer <- hb_buffer_create
    case text buf of
        Right bs -> hb_buffer_add_bytestring buffer bs
        -- Convert text to bytestring for now due to the text 2.0 UTF-8 transition.
        -- Unfortunately this may prevent Harfbuzz from reading opening context
        -- So for correctness we'll eventually want to depend on text>2.0
        Left txt -> hb_buffer_add_bytestring buffer $ encodeUtf8 txt
    hb_buffer_set_content_type buffer $ case contentType buf of
withBuffer :: Buffer -> (Buffer' -> IO a) -> IO a
withBuffer buf cb = withNewBuffer $ \buf' -> bufferWithText buf' (text buf) $ do
    hb_buffer_set_content_type buf' $ case contentType buf of
        Nothing -> 0
        Just ContentTypeUnicode -> 1
        Just ContentTypeGlyphs -> 2
    hb_buffer_set_direction buffer $ dir2int $ direction buf
    hb_buffer_set_direction buf' $ dir2int $ direction buf
    case script buf of
        Just script' -> hb_buffer_set_script buffer $ hb_script_from_string script'
        Just script' -> hb_buffer_set_script buf' $ script_from_string script'
        Nothing -> return ()
    case language buf of
        Just lang' -> hb_buffer_set_language buffer =<< hb_language_from_string lang'
        Just lang' -> hb_buffer_set_language buf' =<< hb_language_from_string lang'
        Nothing -> return ()
    hb_buffer_set_flags buffer $ Prelude.foldl (.|.) 0 [
    hb_buffer_set_flags buf' $ Prelude.foldl (.|.) 0 [
        if beginsText buf then 1 else 0,
        if endsText buf then 2 else 0,
        if preserveDefaultIgnorables buf then 4 else 0,
        if removeDefaultIgnorables buf then 8 else 0,
        if don'tInsertDottedCircle buf then 16 else 0
      ]
    hb_buffer_set_cluster_level buffer $ case clusterLevel buf of
    hb_buffer_set_cluster_level buf' $ case clusterLevel buf of
        ClusterMonotoneGraphemes -> 0
        ClusterMonotoneChars -> 1
        ClusterChars -> 2
    hb_buffer_set_invisible_glyph buffer $ c2w $ invisibleGlyph buf
    hb_buffer_set_replacement_codepoint buffer $ c2w $ replacementCodepoint buf
    hb_buffer_set_invisible_glyph buf' $ c2w $ invisibleGlyph buf
    hb_buffer_set_replacement_codepoint buf' $ c2w $ replacementCodepoint buf
--    hb_buffer_set_not_found_glyph buf' $ c2w $ notFoundGlyph buf
    case (contentType buf, direction buf, script buf, language buf) of
        (Just ContentTypeUnicode, Nothing, _, _) -> hb_buffer_guess_segment_properties buffer
        (Just ContentTypeUnicode, _, Nothing, _) -> hb_buffer_guess_segment_properties buffer
        (Just ContentTypeUnicode, _, _, Nothing) -> hb_buffer_guess_segment_properties buffer
    newForeignPtr hb_buffer_destroy buffer
        (Just ContentTypeUnicode, Nothing, _, _) -> hb_buffer_guess_segment_properties buf'
        (Just ContentTypeUnicode, _, Nothing, _) -> hb_buffer_guess_segment_properties buf'
        (Just ContentTypeUnicode, _, _, Nothing) -> hb_buffer_guess_segment_properties buf'
    cb buf'
foreign import ccall "hb_buffer_set_content_type" hb_buffer_set_content_type
    :: Buffer' -> Int -> IO ()
foreign import ccall "hb_buffer_set_script" hb_buffer_set_script
    :: Buffer' -> Word32 -> IO ()
foreign import ccall "hb_buffer_set_language" hb_buffer_set_language
    :: Buffer' -> Language -> IO ()
foreign import ccall "hb_buffer_set_flags" hb_buffer_set_flags :: Buffer' -> Int -> IO ()
foreign import ccall "hb_buffer_set_cluster_level" hb_buffer_set_cluster_level
    :: Buffer' -> Int -> IO ()
foreign import ccall "hb_buffer_set_invisible_glyph" hb_buffer_set_invisible_glyph
    :: Buffer' -> Word32 -> IO ()
foreign import ccall "hb_buffer_set_replacement_codepoint" hb_buffer_set_replacement_codepoint
    :: Buffer' -> Word32 -> IO ()
--foreign import ccall "hb_buffer_set_not_found_glyph" hb_buffer_set_not_found_glyph
--    :: Buffer' -> Word32 -> IO ()
foreign import ccall "hb_buffer_guess_segment_properties" hb_buffer_guess_segment_properties
    :: Buffer' -> IO ()

------
--- C-to-Haskell conversion
------
data GlyphInfo = GlyphInfo {
    codepoint :: Word32,
    -- ^ Glyph index (or unicode codepoint)
    cluster :: Word32
    -- ^ The index of the character in the original text that corresponds to
    -- this `GlyphInfo`. More than one `GlyphInfo` may have the same `cluster`
    -- value if they resulted from the same character, & when more than one
    -- character gets merged into the same glyph `GlyphInfo` will have the
    -- smallest cluster value of them.
    -- By default some characters are merged into the same cluster even when
    -- they are seperate glyphs, `Buffer`'s `clusterLevel` property allows
    -- selecting more fine grained cluster handling.
} deriving (Show, Read, Eq, Generic)
instance GStorable GlyphInfo
glyphInfos buf' = do
    arr <- hb_buffer_get_glyph_infos buf' nullPtr
    length <- hb_buffer_get_length buf'
    if length == 0 || arr == nullPtr
    then return []
    else forM [0..fromEnum length - 1] $ peekElemOff arr
foreign import ccall "hb_buffer_get_glyph_infos" hb_buffer_get_glyph_infos
    :: Buffer' -> Ptr Word -> IO (Ptr GlyphInfo)
foreign import ccall "hb_buffer_get_length" hb_buffer_get_length :: Buffer' -> IO Word
-- NOTE: The array returned from FFI is valid as long as the buffer is.

-- | The Buffer's glyph information list.
glyphInfos :: Buffer' -> [GlyphInfo]
glyphInfos = unsafePerformIO . glyphInfos'
-- | Variant of `glyphInfos` for use in IO code.
glyphInfos' :: Buffer' -> IO [GlyphInfo]
glyphInfos' buf' = alloca $ \length' -> do
    arr <- withForeignPtr buf' $ \buf'' -> hb_buffer_get_glyph_infos buf'' length'
    length <- peek length'
data GlyphPos = GlyphPos {
    x_advance :: Int32,
    -- ^ How much the line advances after drawing this glyph when setting text
    -- in horizontal direction.
    y_advance :: Int32,
    -- ^ How much the line advances after drawing this glyph when setting text
    -- in vertical direction.
    x_offset :: Int32,
    -- ^ How much the glyph moves on the X-axis before drawing it, this should
    -- not effect how much the line advances.
    y_offset :: Int32
    -- ^ How much the glyph moves on the Y-axis before drawing it, this should
    -- not effect how much the line advances.
} deriving (Show, Read, Eq, Generic)
instance GStorable GlyphPos
glyphsPos buf' = do
    arr <- hb_buffer_get_glyph_positions buf' nullPtr
    length <- hb_buffer_get_length buf'
    if length == 0 || arr == nullPtr
    then return []
    else forM [0..fromEnum length - 1] $ peekElemOff arr
-- | The Buffer's glyph position list. If not already computed defaults to all 0s.
glyphsPos :: Buffer' -> [GlyphPos]
glyphsPos = unsafePerformIO . glyphsPos'
-- | Variant of `glyphsPos` for use in IO code.
glyphsPos' :: Buffer' -> IO [GlyphPos]
glyphsPos' buf' = alloca $ \length' -> do
      arr <- withForeignPtr buf' $ \buf'' -> hb_buffer_get_glyph_positions buf'' length'
      length <- peek length'
      if length == 0 || arr == nullPtr
      then return []
      else forM [0..fromEnum length-1] $ peekElemOff arr
foreign import ccall "hb_buffer_get_glyph_positions" hb_buffer_get_glyph_positions
    :: Buffer' -> Ptr Word -> IO (Ptr GlyphPos)
-- NOTE: The array returned from FFI is valid as long as the buffer is.

-- | Converts from the C representation of a Buffer used internally back into a
-- pure-Haskell representation.
thaw :: Buffer' -> Buffer
thaw = unsafePerformIO . thaw'
-- | Variant of `thaw` for use in IO code.
thaw' buf' = do
    let getter cb = unsafeInterleaveIO $ withForeignPtr buf' cb
    glyphInfos' <- glyphInfos' buf'
    contentType' <- getter hb_buffer_get_content_type
    direction' <- getter hb_buffer_get_direction
    script' <- getter hb_buffer_get_script
    language' <- unsafeInterleaveIO $ do
        lang <- withForeignPtr buf' $ \buf'' -> hb_buffer_get_language buf''
        peekCString $ hb_language_to_string lang
    flags' <- getter hb_buffer_get_flags
    clusterLevel' <- getter hb_buffer_get_cluster_level
    invisibleGlyph' <- getter hb_buffer_get_invisible_glyph
    replacementCodepoint' <- getter hb_buffer_get_replacement_codepoint
    return Buffer {
        text = Right $ LBS.fromStrict $ encodeUTF8 $ Prelude.map codepoint glyphInfos',
thawBuffer :: Buffer' -> IO Buffer
thawBuffer buf' = do
    glyphInfos' <- glyphInfos buf'
    contentType' <- hb_buffer_get_content_type buf'
    direction' <- hb_buffer_get_direction buf'
    script' <- hb_buffer_get_script buf'
    language'' <- hb_buffer_get_language buf'
    language' <- peekCString language''
    flags' <- hb_buffer_get_flags buf'
    clusterLevel' <- hb_buffer_get_cluster_level buf'
    invisibleGlyph' <- hb_buffer_get_invisible_glyph buf'
    replacementCodepoint' <- hb_buffer_get_replacement_codepoint buf'
    return defaultBuffer {
        text = Lazy.pack $ Prelude.map (w2c . codepoint) glyphInfos',
        contentType = case contentType' of
            1 -> Just ContentTypeUnicode
            2 -> Just ContentTypeGlyphs
            _ -> Nothing,
        direction = int2dir direction',
        script = Just $ tag_to_string script',
        language = Just language',
        script = Just $ hb_tag_to_string script',
        beginsText = testBit flags' 0, endsText = testBit flags' 1,
        preserveDefaultIgnorables = testBit flags' 2,
        removeDefaultIgnorables = testBit flags' 3,


@@ 286,91 375,18 @@ thaw' buf' = do
            1 -> ClusterMonotoneChars
            2 -> ClusterChars
            _ -> ClusterMonotoneGraphemes,
        invisibleGlyph = w2c invisibleGlyph', replacementCodepoint = w2c replacementCodepoint'
      }

foreign import ccall "hb_buffer_create" hb_buffer_create :: IO Buffer_
foreign import ccall "&hb_buffer_destroy" hb_buffer_destroy :: FunPtr (Buffer_ -> IO ())
foreign import ccall "hb_buffer_add_utf8" hb_buffer_add_utf8
    :: Buffer_ -> Ptr Word8 -> Int -> Int -> Int -> IO ()
hb_buffer_add_bytestring _ Lazy.Empty = return ()
hb_buffer_add_bytestring buf (Lazy.Chunk (Strict.PS ptr offset length) next) = do
    withForeignPtr ptr $ \ptr' -> hb_buffer_add_utf8 buf ptr' length offset (length - offset)
    hb_buffer_add_bytestring buf next
foreign import ccall "hb_buffer_set_content_type" hb_buffer_set_content_type
    :: Buffer_ -> Int -> IO ()
foreign import ccall "hb_buffer_set_direction" hb_buffer_set_direction
    :: Buffer_ -> Int -> IO ()
hb_tag_from_string :: String -> Word32
hb_tag_from_string str = case str ++ Prelude.repeat '\0' of
    c1:c2:c3:c4:_ -> Prelude.foldl (.|.) 0 [
        shiftL (c2w c1 .&. 0x7) 24,
        shiftL (c2w c2 .&. 0x7) 16,
        shiftL (c2w c3 .&. 0x7) 8,
        shiftL (c2w c4 .&. 0x7) 0
      ]
    _ -> 0
titlecase :: String -> String
titlecase "" = ""
titlecase (c:cs) = toUpper c : Prelude.map toLower cs
hb_script_from_string str = hb_tag_from_string $ case titlecase str of
    'Q':'a':'a':'i':_ -> "Zinh"
    'Q':'a':'a':'c':_ -> "Copt"

    'A':'r':'a':'n':_ -> "Arab"
    'C':'y':'r':'s':_ -> "Cyrl"
    'G':'e':'o':'k':_ -> "Geor"
    'H':'a':'n':'s':_ -> "Hani"
    'H':'a':'n':'t':_ -> "Hani"
    'J':'a':'m':'o':_ -> "Hang"
    'L':'a':'t':'f':_ -> "Latn"
    'L':'a':'t':'g':_ -> "Latn"
    'S':'y':'r':'e':_ -> "Syrc"
    'S':'y':'r':'j':_ -> "Syrc"
    'S':'y':'r':'n':_ -> "Syrc"
foreign import ccall "hb_buffer_set_script" hb_buffer_set_script
    :: Buffer_ -> Word32 -> IO ()
foreign import ccall "hb_script_get_horizontal_direction" hb_script_get_horizontal_direction
    :: Word32 -> Int
foreign import ccall "hb_language_from_string" hb_language_from_string'
    :: CString -> Int -> IO Int
hb_language_from_string :: String -> IO Int
hb_language_from_string str =
    withCString str $ \str' -> hb_language_from_string' str' (-1)
foreign import ccall "hb_buffer_set_language" hb_buffer_set_language
    :: Buffer_ -> Int -> IO ()
foreign import ccall "hb_buffer_set_flags" hb_buffer_set_flags :: Buffer_ -> Int -> IO ()
foreign import ccall "hb_buffer_set_cluster_level" hb_buffer_set_cluster_level
    :: Buffer_ -> Int -> IO ()
foreign import ccall "hb_buffer_set_invisible_glyph" hb_buffer_set_invisible_glyph
    :: Buffer_ -> Word32 -> IO ()
foreign import ccall "hb_buffer_set_replacement_codepoint" hb_buffer_set_replacement_codepoint
    :: Buffer_ -> Word32 -> IO ()
foreign import ccall "hb_buffer_guess_segment_properties" hb_buffer_guess_segment_properties
    :: Buffer_ -> IO ()


        invisibleGlyph = w2c invisibleGlyph',
        replacementCodepoint = w2c replacementCodepoint'
    }
foreign import ccall "hb_buffer_get_content_type" hb_buffer_get_content_type
    :: Buffer_ -> IO Int
foreign import ccall "hb_buffer_get_direction" hb_buffer_get_direction :: Buffer_ -> IO Int
foreign import ccall "hb_buffer_get_script" hb_buffer_get_script :: Buffer_ -> IO Word32
hb_tag_to_string :: Word32 -> String
hb_tag_to_string tag = [
    w2c (shiftR tag 24 .&. 0x7),
    w2c (shiftR tag 16 .&. 0x7),
    w2c (shiftR tag 8 .&. 0x7),
    w2c (shiftR tag 0 .&. 0x7)
  ]
foreign import ccall "hb_buffer_get_language" hb_buffer_get_language :: Buffer_ -> IO (Ptr ())
foreign import ccall "hb_language_to_string" hb_language_to_string :: Ptr () -> CString
foreign import ccall "hb_buffer_get_flags" hb_buffer_get_flags :: Buffer_ -> IO Int
    :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_direction" hb_buffer_get_direction :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_script" hb_buffer_get_script :: Buffer' -> IO Word32
foreign import ccall "hb_buffer_get_language" hb_buffer_get_language :: Buffer' -> IO CString
foreign import ccall "hb_buffer_get_flags" hb_buffer_get_flags :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_cluster_level" hb_buffer_get_cluster_level
    :: Buffer_ -> IO Int
foreign import ccall "hb_buffer_get_glyph_infos" hb_buffer_get_glyph_infos
    :: Buffer_ -> Ptr Word -> IO (Ptr GlyphInfo)
foreign import ccall "hb_buffer_get_glyph_positions" hb_buffer_get_glyph_positions
    :: Buffer_ -> Ptr Word -> IO (Ptr GlyphPos)
    :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_invisible_glyph" hb_buffer_get_invisible_glyph
    :: Buffer_ -> IO Word32
    :: Buffer' -> IO Word32
foreign import ccall "hb_buffer_get_replacement_codepoint" hb_buffer_get_replacement_codepoint
    :: Buffer_ -> IO Word32
    :: Buffer' -> IO Word32


M Data/Text/Glyphize/Font.hs => Data/Text/Glyphize/Font.hs +283 -224
@@ 1,57 1,108 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.Text.Glyphize.Font where

import Data.ByteString
import FreeType.Core.Base
import Data.Text.Glyphize.Buffer (Direction(..), dir2int, hb_tag_to_string)
import Data.ByteString.Internal (ByteString(..))
import Data.ByteString (packCStringLen)
import Data.Word (Word8, Word32)
import Data.Int (Int32)
import FreeType.Core.Base (FT_Face)
import Data.Text.Glyphize.Buffer (tag_to_string, tag_from_string, Direction, dir2int)

import System.IO.Unsafe (unsafePerformIO)
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.ForeignPtr
import qualified Foreign.Concurrent as Conc
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)
import Codec.Binary.UTF8.Light (w2c, c2w)
import Data.Maybe (fromMaybe)

type Face = ForeignPtr Face'
type Face_ = Ptr Face'
data Face'
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.Storable (Storable(..))
import Foreign.Storable.Generic (GStorable(..))
import GHC.Generics (Generic(..))
import Foreign.C.String (CString, withCString, withCStringLen, peekCString, peekCStringLen)

------
--- Features & Variants
------

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

------
--- Faces
------

foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Word
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

foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Word -> IO Face_
foreign import ccall "hb_face_destroy" hb_face_destroy :: Face_ -> IO ()
foreign import ccall "&hb_face_destroy" hb_face_destroy' :: FunPtr (Face_ -> IO ())
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
    Conc.newForeignPtr face $ hb_face_destroy face
    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 ())

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
    unsafePerformIO . 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_

foreign import ccall "hb_face_get_empty" hb_face_get_empty :: Face_
emptyFace :: Face
emptyFace = unsafePerformIO $ newForeignPtr hb_face_destroy' hb_face_get_empty
emptyFace = unsafePerformIO $ newForeignPtr hb_face_destroy hb_face_get_empty
foreign import ccall "hb_face_get_empty" hb_face_get_empty :: Face_

foreign import ccall "hb_face_get_table_tags" hb_face_get_table_tags
    :: Face_ -> Word -> Ptr Word -> Ptr Word32 -> IO Word
faceTableTags :: Face -> Word -> Word -> (Word, [String])
faceTableTags fce offs cnt = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
    alloca $ \cnt' -> allocaBytes (fromEnum cnt * 4) $ \arr' -> do


@@ 59,81 110,94 @@ faceTableTags fce offs cnt = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
        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 hb_tag_to_string 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

foreign import ccall "hb_face_get_glyph_count" hb_face_get_glyph_count :: Face_ -> 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

foreign import ccall "hb_face_collect_unicodes" hb_face_collect_unicodes
    :: Face_ -> Set_ -> IO ()
faceCollectUnicodes :: Face -> [Word32]
faceCollectUnicodes = faceCollectFunc hb_face_collect_unicodes
foreign import ccall "hb_face_collect_unicodes" hb_face_collect_unicodes
    :: Face_ -> Set_ -> IO ()

foreign import ccall "hb_face_collect_variation_selectors"
    hb_face_collect_variation_selectors :: 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 ()
faceCollectVarUnicodes :: Face -> Word32 -> [Word32]
faceCollectVarUnicodes fce varSel = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
    set <- createSet
    withForeignPtr set $ hb_face_collect_variation_unicodes fce' varSel
    set2list set

foreign import ccall "hb_face_get_index" hb_face_get_index :: Face_ -> Word
faceIndex :: Face -> Word
faceIndex = faceFunc hb_face_get_index
foreign import ccall "hb_face_get_index" hb_face_get_index :: Face_ -> Word

foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Word
-- | units-per-em
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_

-- Defer implementation of other functions...
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_

---
-- TODO Do we want setters? How to expose those?
-- TODO Face builders?

------
--- Fonts
------

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 :: 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
    Conc.newForeignPtr font $ hb_font_destroy 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 ())

foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced
    :: FT_Face -> IO Font_
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
    newForeignPtr hb_font_destroy font
foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced
    :: FT_Face -> IO 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
emptyFont = unsafePerformIO $ newForeignPtr hb_font_destroy hb_font_get_empty
foreign import ccall "hb_font_get_empty" hb_font_get_empty :: Font_

foreign import ccall "hb_font_get_glyph" hb_font_get_glyph
    :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
fontFace :: Font -> Face
fontFace font = unsafePerformIO $ withForeignPtr font $ \font' -> do
    face' <- hb_font_get_face font'
    newForeignPtr_ face' -- FIXME: Keep the font alive...
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

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


@@ 141,9 205,10 @@ fontGlyphAdvance font glyph dir = unsafePerformIO $
        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 ()

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


@@ 154,10 219,9 @@ fontGlyphContourPoint font glyph index = unsafePerformIO $
            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

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


@@ 169,30 233,15 @@ fontGlyphContourPointForOrigin font glyph index dir = unsafePerformIO $
            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
}
instance Storable GlyphExtents where
    sizeOf _ = 4 * sizeOf (undefined :: Word32)
    alignment _ = alignment (undefined :: Word32)
    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
} deriving (Generic)
instance GStorable GlyphExtents 
fontGlyphExtents :: Font -> Word32 -> Maybe GlyphExtents
fontGlyphExtents font glyph = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do


@@ 200,10 249,9 @@ fontGlyphExtents font glyph = unsafePerformIO $
        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

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


@@ 211,9 259,10 @@ fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $
        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

foreign import ccall "hb_font_get_glyph_from_name" hb_font_get_glyph_from_name
    :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
fontGlyphFromName :: Font -> String -> Maybe Word32
fontGlyphFromName font name = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do


@@ 222,22 271,27 @@ fontGlyphFromName font name = unsafePerformIO $
        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

foreign import ccall "hb_font_get_glyph_h_advance" hb_font_get_glyph_h_advance
    :: Font_ -> Word32 -> Int32
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

foreign import ccall "hb_font_get_glyph_h_kerning" hb_font_get_glyph_h_kerning
    :: Font_ -> Word32 -> 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

foreign import ccall "hb_font_get_glyph_h_origin" hb_font_get_glyph_h_origin
    :: Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphHOrigin :: Font -> Word32 -> Maybe (Int32, Int32)
fontGlyphHOrigin font glyph = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
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


@@ 245,83 299,81 @@ fontGlyphHOrigin font glyph = unsafePerformIO $
            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


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 ()
fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Int32, Int32)
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'
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_name" hb_font_get_glyph_name
    :: Font_ -> Word32 -> CString -> Word -> IO Bool
fontGlyphName :: Font -> Word32 -> Word -> Maybe String
fontGlyphName font glyph length = let lengthi = fromEnum length in unsafePerformIO $
    withForeignPtr font $ \font' -> allocaBytes lengthi $ \ret -> do
        success <- hb_font_get_glyph_name font' glyph ret length
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 return . Just =<< peekCString ret
        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

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 ()
fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Int32, Int32)
fontGlyphOriginForDir font glyph dir = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
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 ()

foreign import ccall "hb_font_get_glyph_v_advance"
    hb_font_get_glyph_v_advance :: Font_ -> Word32 -> Int32
fontGlyphVAdvance :: Font -> Word32 -> Int32
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 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
-- Skipping Draw methodtables, easier to use FreeType for that.

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 Word -> Ptr Word -> IO ()
fontPPEm :: Font -> (Word, Word)
fontPPEm font = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
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

fontPPEm :: Font -> (Word32, Word32)
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)
        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 ()

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_ptem" hb_font_get_ptem :: Font_ -> Float

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


@@ 329,9 381,14 @@ fontScale font = unsafePerformIO $
        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 ()

{-fontSyntheticSlant :: Font -> Float
fontSyntheticSlant = fontFunc hb_font_get_synthetic_slant
foreign import ccall "hb_font_get_synthetic_slant" hb_font_get_synthetic_slant ::
    Font_ -> Float-}

foreign import ccall "hb_font_get_variation_glyph" hb_font_get_variation_glyph
    :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
fontVarGlyph :: Font -> Word32 -> Word32 -> Maybe Word32
fontVarGlyph font unicode varSel = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \glyph' -> do


@@ 339,18 396,27 @@ fontVarGlyph font unicode varSel = unsafePerformIO $
        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

{-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..fromEnum length-1] $ peekElemOff arr
foreign import ccall "hb_font_get_var_coords_design"
    hb_font_get_var_coords_design :: Font_ -> Ptr Word -> IO (Ptr Float)-}

foreign import ccall "hb_font_get_var_coords_normalized"
    hb_font_get_var_coords_normalized :: Font_ -> Ptr Word -> 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..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)

foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string
    :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
fontTxt2Glyph :: Font -> String -> Maybe Word32
fontTxt2Glyph font str = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do


@@ 359,61 425,52 @@ fontTxt2Glyph font str = unsafePerformIO $
        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

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
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
}

instance Storable FontExtents where
    sizeOf _ = sizeOf (undefined :: Int32) * 3
    alignment _ = alignment (undefined :: Int32)
    peek p = do
        let q = castPtr p
        asc <- peek q
        desc <- peekElemOff q 1
        gap <- peekElemOff q 2
        return $ FontExtents asc desc gap
    poke p (FontExtents asc desc gap) = do
        let q = castPtr p
        poke q asc
        pokeElemOff q 1 desc
        pokeElemOff q 2 gap

foreign import ccall "hb_font_get_extents_for_direction"
    hb_font_get_extents_for_direction :: Font_ -> Int -> Ptr FontExtents -> IO ()
} 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 ()

foreign import ccall "hb_font_get_h_extents" hb_font_get_h_extents
    :: Font_ -> Ptr FontExtents -> IO Bool
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_v_extents" hb_font_get_v_extents
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

-- Not exposing the Font Funcs API as being extremely imparative with little value to callers.

---
------
--- Configurable fonts
------

data FontOptions = FontOptions {
    optionPPEm :: Maybe (Word, Word),


@@ 424,7 481,6 @@ defaultFontOptions = FontOptions {
    optionPPEm = Nothing, optionPtEm = Nothing,
    optionScale = Nothing
}

_setFontOptions font opts = do
    case optionPPEm opts of
        Just (x, y) -> hb_font_set_ppem font x y


@@ 435,47 491,50 @@ _setFontOptions font opts = do
    case optionScale opts of
        Just (x, y) -> hb_font_set_scale font x y
        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 ()

createFontWithOptions :: FontOptions -> Face -> Font
createFontWithOptions opts fce = unsafePerformIO $ do
    font <- withForeignPtr fce $ hb_font_create
    _setFontOptions font opts
    hb_font_make_immutable font
    Conc.newForeignPtr font $ hb_font_destroy 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
    newForeignPtr hb_font_destroy font

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 ()

-- Defer implementation of other functions...

---
------
--- Internal
------

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 :: 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
    Conc.newForeignPtr blob $ hb_blob_destroy 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


@@ 483,18 542,22 @@ 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'
foreign import ccall "hb_set_create" hb_set_create :: IO Set_
foreign import ccall "&hb_set_destroy" hb_set_destroy :: FunPtr (Set_ -> IO ())

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 ())

foreign import ccall "hb_set_next" hb_set_next :: Set_ -> Ptr Word32 -> IO Bool
setNext :: Set -> Word32 -> Maybe Word32
setNext set iter = unsafePerformIO $ withForeignPtr set $ \set' -> alloca $ \iter' -> do
    poke iter' iter


@@ 502,14 565,10 @@ setNext set iter = unsafePerformIO $ withForeignPtr set $ \set' -> alloca $ \ite
    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 = []

faceCollectFunc :: (Face_ -> Set_ -> IO ()) -> (Face -> [Word32])
faceCollectFunc cb fce = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
    set <- createSet
    withForeignPtr set $ cb fce'
    set2list set


M Main.hs => Main.hs +9 -14
@@ 1,29 1,24 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports, OverloadedStrings #-}
module Main where

import "harfbuzz-pure" Data.Text.Glyphize
import "harfbuzz-pure" Data.Text.Glyphize.Buffer
import "harfbuzz-pure" Data.Text.Glyphize.Font

import Control.Parallel.Strategies (parMap, rpar)

import System.Environment
import Data.ByteString.Lazy as LBS
import Data.ByteString as BS
import Data.ByteString.Char8 as UTF8
import Data.Text.Lazy (pack)
import qualified Data.ByteString as BS
import System.Environment (getArgs)

shapeStr font word = shape font $ defaultBuffer {
    text = Right $ LBS.fromStrict $ UTF8.pack word
  }
shapeStr font word = shape font defaultBuffer { text = pack word } []

main :: IO ()
main = do
    print versionString
    words <- getArgs
    if Prelude.null words
    then print $ guessSegmentProperties $ defaultBuffer { text = Right "Testing, testing"}
    then print $ guessSegmentProperties $ defaultBuffer { text = "Testing, testing"}
    else do
      blob <- BS.readFile "assets/Lora-Regular.ttf"
      let font = createFont $ createFace blob 0
      print $ parMap rpar (shapeStr font) words
      case words of
        "!":words' -> print $ shape font (defaultBuffer { text = pack $ unwords words' }) []
        _ -> print $ parMap rpar (shapeStr font) words


A assets/Lora-Bold.ttf => assets/Lora-Bold.ttf +0 -0
A assets/Lora-BoldItalic.ttf => assets/Lora-BoldItalic.ttf +0 -0
A assets/Lora-Italic.ttf => assets/Lora-Italic.ttf +0 -0
A assets/Lora-Regular.ttf => assets/Lora-Regular.ttf +0 -0
A assets/Neuton-Regular.ttf => assets/Neuton-Regular.ttf +0 -0
A assets/OFL.txt => assets/OFL.txt +94 -0
@@ 0,0 1,94 @@
Copyright (c) 2010, 2011, Brian Zick (artistenator@gmail.com www.21326.info),
with Reserved Font Name "Neuton" "Neuton Italic" "Neuton Cursive"

This Font Software is licensed under the SIL Open Font License, Version 1.1.
This license is copied below, and is also available with a FAQ at:
http://scripts.sil.org/OFL


-----------------------------------------------------------
SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
-----------------------------------------------------------

PREAMBLE
The goals of the Open Font License (OFL) are to stimulate worldwide
development of collaborative font projects, to support the font creation
efforts of academic and linguistic communities, and to provide a free and
open framework in which fonts may be shared and improved in partnership
with others.

The OFL allows the licensed fonts to be used, studied, modified and
redistributed freely as long as they are not sold by themselves. The
fonts, including any derivative works, can be bundled, embedded, 
redistributed and/or sold with any software provided that any reserved
names are not used by derivative works. The fonts and derivatives,
however, cannot be released under any other type of license. The
requirement for fonts to remain under this license does not apply
to any document created using the fonts or their derivatives.

DEFINITIONS
"Font Software" refers to the set of files released by the Copyright
Holder(s) under this license and clearly marked as such. This may
include source files, build scripts and documentation.

"Reserved Font Name" refers to any names specified as such after the
copyright statement(s).

"Original Version" refers to the collection of Font Software components as
distributed by the Copyright Holder(s).

"Modified Version" refers to any derivative made by adding to, deleting,
or substituting -- in part or in whole -- any of the components of the
Original Version, by changing formats or by porting the Font Software to a
new environment.

"Author" refers to any designer, engineer, programmer, technical
writer or other person who contributed to the Font Software.

PERMISSION & CONDITIONS
Permission is hereby granted, free of charge, to any person obtaining
a copy of the Font Software, to use, study, copy, merge, embed, modify,
redistribute, and sell modified and unmodified copies of the Font
Software, subject to the following conditions:

1) Neither the Font Software nor any of its individual components,
in Original or Modified Versions, may be sold by itself.

2) Original or Modified Versions of the Font Software may be bundled,
redistributed and/or sold with any software, provided that each copy
contains the above copyright notice and this license. These can be
included either as stand-alone text files, human-readable headers or
in the appropriate machine-readable metadata fields within text or
binary files as long as those fields can be easily viewed by the user.

3) No Modified Version of the Font Software may use the Reserved Font
Name(s) unless explicit written permission is granted by the corresponding
Copyright Holder. This restriction only applies to the primary font name as
presented to the users.

4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
Software shall not be used to promote, endorse or advertise any
Modified Version, except to acknowledge the contribution(s) of the
Copyright Holder(s) and the Author(s) or with their explicit written
permission.

5) The Font Software, modified or unmodified, in part or in whole,
must be distributed entirely under this license, and must not be
distributed under any other license. The requirement for fonts to
remain under this license does not apply to any document created
using the Font Software.

TERMINATION
This license becomes null and void if any of the above conditions are
not met.

DISCLAIMER
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
OTHER DEALINGS IN THE FONT SOFTWARE.


A assets/SIL Open Font License.txt => assets/SIL Open Font License.txt +44 -0
@@ 0,0 1,44 @@
Copyright (c) 2011-2013, Cyreal (www.cyreal.org a@cyreal.org), with
Reserved Font Name 'Lora'

This Font Software is licensed under the SIL Open Font License, Version 1.1.
This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL

-----------------------------------------------------------
SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
-----------------------------------------------------------

PREAMBLE
The goals of the Open Font License (OFL) are to stimulate worldwide development of collaborative font projects, to support the font creation efforts of academic and linguistic communities, and to provide a free and open framework in which fonts may be shared and improved in partnership with others.

The OFL allows the licensed fonts to be used, studied, modified and redistributed freely as long as they are not sold by themselves. The fonts, including any derivative works, can be bundled, embedded, redistributed and/or sold with any software provided that any reserved names are not used by derivative works. The fonts and derivatives, however, cannot be released under any other type of license. The requirement for fonts to remain under this license does not apply to any document created using the fonts or their derivatives.

DEFINITIONS
"Font Software" refers to the set of files released by the Copyright Holder(s) under this license and clearly marked as such. This may include source files, build scripts and documentation.

"Reserved Font Name" refers to any names specified as such after the copyright statement(s).

"Original Version" refers to the collection of Font Software components as distributed by the Copyright Holder(s).

"Modified Version" refers to any derivative made by adding to, deleting, or substituting -- in part or in whole -- any of the components of the Original Version, by changing formats or by porting the Font Software to a new environment.

"Author" refers to any designer, engineer, programmer, technical writer or other person who contributed to the Font Software.

PERMISSION & CONDITIONS
Permission is hereby granted, free of charge, to any person obtaining a copy of the Font Software, to use, study, copy, merge, embed, modify, redistribute, and sell modified and unmodified copies of the Font Software, subject to the following conditions:

1) Neither the Font Software nor any of its individual components, in Original or Modified Versions, may be sold by itself.

2) Original or Modified Versions of the Font Software may be bundled, redistributed and/or sold with any software, provided that each copy contains the above copyright notice and this license. These can be included either as stand-alone text files, human-readable headers or in the appropriate machine-readable metadata fields within text or binary files as long as those fields can be easily viewed by the user.

3) No Modified Version of the Font Software may use the Reserved Font Name(s) unless explicit written permission is granted by the corresponding Copyright Holder. This restriction only applies to the primary font name as presented to the users.

4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font Software shall not be used to promote, endorse or advertise any Modified Version, except to acknowledge the contribution(s) of the Copyright Holder(s) and the Author(s) or with their explicit written permission.

5) The Font Software, modified or unmodified, in part or in whole, must be distributed entirely under this license, and must not be distributed under any other license. The requirement for fonts to remain under this license does not apply to any document created using the Font Software.

TERMINATION
This license becomes null and void if any of the above conditions are not met.

DISCLAIMER
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE.
\ No newline at end of file


M harfbuzz-pure.cabal => harfbuzz-pure.cabal +3 -3
@@ 60,8 60,8 @@ library
  -- other-extensions:    
  
  -- Other library packages from which modules are imported.
  build-depends:       base >=4.9 && <5, freetype2 >= 0.2,
                       bytestring >= 0.10.8.2 && < 0.12, text >= 1 && <3, utf8-light >= 0.3 && < 1
  build-depends:       base >=4.12 && <4.13, text >= 2.0 && < 3, utf8-light >= 0.4 && < 0.5,
                       bytestring >= 0.11, freetype2 >= 0.2, derive-storable >= 0.3 && < 1
  pkgconfig-depends:   harfbuzz
  
  -- Directories containing source files.


@@ 75,7 75,7 @@ executable shape-text
  main-is:             Main.hs

  -- Other library packages from which modules are imported
  build-depends:       base >=4.9 && <5, harfbuzz-pure, parallel  >= 2.2 && < 4, bytestring
  build-depends:       base >=4.9 && <5, harfbuzz-pure, parallel  >= 2.2 && < 4, text, bytestring

  -- Directories containing source files.
  hs-source-dirs:      .