harfbuzz-pure 0.1.0.0 → 0.1.0.1
raw patch · 5 files changed
+1091/−563 lines, 5 filesdep +derive-storabledep −utf8-lightdep ~basedep ~bytestringdep ~text
Dependencies added: derive-storable
Dependencies removed: utf8-light
Dependency ranges changed: base, bytestring, text
Files
- Data/Text/Glyphize.hs +59/−62
- Data/Text/Glyphize/Buffer.hs +391/−254
- Data/Text/Glyphize/Font.hs +628/−229
- Main.hs +9/−14
- harfbuzz-pure.cabal +4/−4
Data/Text/Glyphize.hs view
@@ -1,77 +1,72 @@-module Data.Text.Glyphize where+module Data.Text.Glyphize (shape, version, versionAtLeast, versionString, -import Data.Text.Glyphize.Buffer-import Data.Text.Glyphize.Font+ Buffer(..), ContentType(..), ClusterLevel(..), Direction(..), defaultBuffer,+ dirFromStr, dirToStr, dirReverse, dirBackward, dirForward, dirHorizontal, dirVertical,+ scriptHorizontalDir, languageDefault, tag_from_string, tag_to_string, guessSegmentProperties, -import Data.Word+ GlyphInfo(..), GlyphPos(..), Feature(..), featTag, Variation(..), varTag,+ parseFeature, unparseFeature, parseVariation, unparseVariation, globalStart, globalEnd, -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)+ countFace, Face, createFace, ftCreateFace, emptyFace, faceTableTags, faceGlyphCount,+ faceCollectUnicodes, faceCollectVarSels, faceCollectVarUnicodes, faceIndex, faceUpem,+ faceBlob, faceTable, -foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer_ -> Ptr Feature -> Int -> IO ()+ 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, --- | 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 []+ GlyphExtents(..), fontGlyphExtents, fontGlyphExtentsForOrigin,+ FontExtents(..), fontExtentsForDir, fontHExtents, fontVExtents,+ FontOptions(..), defaultFontOptions, createFontWithOptions, ftCreateFontWithOptions, + ) where --- 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...+import Data.Text.Glyphize.Font+import Data.Text.Glyphize.Buffer -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'+import System.IO.Unsafe (unsafePerformIO)+import Foreign.Ptr (Ptr(..))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (peek) - 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'+import Foreign.C.String (CString(..), peekCString)+import Foreign.Marshal.Array (withArrayLen) --- | 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+-- | Shapes the text in the given `Buffer` according to the given `Font`+-- yielding glyphs and their positions.+-- If any `Feature`s are given they will be applied during shaping.+-- If two `Feature`s have the same tag but overlapping ranges+-- the value of the `Feature` with the higher index takes precedance.+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 () --- | Used to avoid segfaults...-{-# NOINLINE shapingSem #-}-shapingSem = unsafePerformIO $ newQSem 25+-- | Fills in unset segment properties based on buffer unicode contents.+-- If buffer is not empty it must have `ContentType` `ContentTypeUnicode`.+-- If buffer script is not set it will be set to the Unicode script of the first+-- character in the buffer that has a script other than "common", "inherited",+-- or "unknown".+-- Next if the buffer direction is not set it will be set to the natural+-- horizontal direction of the buffer script as returned by `scriptHorizontalDirection`.+-- If `scriptHorizontalDirection` returns `Nothing`, then `DirLTR` is used.+-- Finally if buffer language is not set, it will be set to the process's default+-- language as returned by `languageDefault`. This may change in the future by+-- taking buffer script into consideration when choosting a language.+-- Note that `languageDefault` is not thread-safe the first time it is called.+-- See documentation for that function for details.+guessSegmentProperties :: Buffer -> Buffer+guessSegmentProperties = unsafePerformIO . flip withBuffer thawBuffer foreign import ccall "hb_version" hb_version :: Ptr Int -> Ptr Int -> Ptr Int -> IO ()+-- | Returns the library version as 3 integer components. version :: (Int, Int, Int) version = unsafePerformIO $ alloca $ \a' -> alloca $ \b' -> alloca $ \c' -> do@@ -80,7 +75,9 @@ b <- peek b' c <- peek c' return (a, b, c)+-- | Tests the library version against a minimum value, as 3 integer components. foreign import ccall "hb_version_atleast" versionAtLeast :: Int -> Int -> Int -> Bool foreign import ccall "hb_version_string" hb_version_string :: CString+-- | Returns library version as a string with 3 integer components. versionString :: String versionString = unsafePerformIO $ peekCString hb_version_string
Data/Text/Glyphize/Buffer.hs view
@@ -1,31 +1,37 @@+{-# 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 Control.Exception (bracket) -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 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+------++-- | Text to be shaped or the resulting glyphs, for which language/script/direction/etc. 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 +71,7 @@ -- 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 +79,22 @@ -- ^ 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) +-- | Whether the given text is Unicode or font-specific "glyphs".+data ContentType = ContentTypeUnicode | ContentTypeGlyphs deriving (Eq, Show, Read, Ord)+-- | Defines how fine the groupings represented by `GlyphInfo`'s `cluster` property are.`+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,193 +105,389 @@ 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+------ +-- | The direction of a text segment or buffer.+data Direction = DirLTR | DirRTL | DirTTB | DirBTT deriving (Eq, Show, Read, Ord)+-- | Converts a string to an hb_direction_t.+-- Matching is loose and applies only to the first letter. For examples, +-- "LTR" and "left-to-right" will both return HB_DIRECTION_LTR.+dirFromStr ('L':_) = Just DirLTR+dirFromStr ('l':_) = Just DirLTR+dirFromStr ('R':_) = Just DirRTL+dirFromStr ('r':_) = Just DirRTL+dirFromStr ('T':_) = Just DirTTB+dirFromStr ('t':_) = Just DirTTB+dirFromStr ('B':_) = Just DirBTT+dirFromStr ('b':_) = Just DirBTT+dirFromStr _ = Nothing+-- | Converts an hb_direction_t to a string.+dirToStr DirLTR = "ltr"+dirToStr DirRTL = "rtl"+dirToStr DirTTB = "ttb"+dirToStr DirBTT = "btt"+-- | Reverses a text direction. dirReverse DirLTR = DirRTL dirReverse DirRTL = DirLTR dirReverse DirTTB = DirBTT dirReverse DirBTT = DirTTB+-- | Tests whether a text direction moves backward+-- (from right to left, or from bottom to top). dirBackward dir = dir `Prelude.elem` [DirRTL, DirBTT]+-- | Tests whether a text direction moves forward+-- (from left to right, or from top to bottom). dirForward dir = dir `Prelude.elem` [DirLTR, DirTTB]+-- | Tests whether a text direction is horizontal. dirHorizontal dir = dir `Prelude.elem` [DirLTR, DirRTL]+-- | Tests whether a text direction is vertical. dirVertical dir = dir `Prelude.elem` [DirTTB, DirBTT] ----+-- | Converts a `Direction` to C encoding.+dir2int Nothing = 0+dir2int (Just DirLTR) = 4+dir2int (Just DirRTL) = 5+dir2int (Just DirTTB) = 6+dir2int (Just DirBTT) = 7+-- | Sets `direction` property on C `Buffer'` struct.+foreign import ccall "hb_buffer_set_direction" hb_buffer_set_direction+ :: Buffer' -> Int -> IO () -type Buffer' = ForeignPtr Buffer''+-- | Converts a `Direction` from C encoding.+int2dir 4 = Just DirLTR+int2dir 5 = Just DirRTL+int2dir 6 = Just DirTTB+int2dir 7 = Just DirBTT+int2dir _ = Nothing++-- | Fetches the hb_direction_t of a script when it is set horizontally.+-- All right-to-left scripts will return `DirRTL`.+-- All left-to-right scripts will return `DirLTR`.+-- Scripts that can be written either horizontally or vertically will return `Nothing`.+-- Unknown scripts will return `DirLTR`.+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'+-- | Represents a natural written language.+-- Corresponds to a BCP47 language tag.+type Language = Ptr Language'+-- | Fetch the default language from current locale.+-- NOTE that the first time this function is called, it calls (C code)+-- "setlocale (LC_CTYPE, nullptr)" to fetch current locale.+-- The underlying setlocale function is, in many implementations, NOT threadsafe.+-- To avoid problems, call this function once before multiple threads can call it.+-- This function may be used to fill in missing fields on a `Buffer`.+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++-- | Converts a `String` representing a BCP 47 language tag to the corresponding `Language`.+hb_language_from_string :: String -> IO Language+hb_language_from_string str =+ withCString str $ \str' -> hb_language_from_string' str' (-1)+foreign import ccall "hb_language_from_string" hb_language_from_string'+ :: CString -> Int -> IO Language++{-+-- | Check whether a second language tag is the same or a more specific version+-- of the provided language tag.+-- For example, "fa_IR.utf8" is a more specific tag for "fa" or for "fa_IR".+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+------++-- | Directly corresponds to "hb_buffer_t". data Buffer''-type Buffer_ = Ptr Buffer''+type Buffer' = Ptr Buffer'' --- | 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+-- | Temporarily allocates a `Buffer'`+withNewBuffer :: (Buffer' -> IO a) -> IO a+withNewBuffer cb = bracket hb_buffer_create hb_buffer_destroy cb+foreign import ccall "hb_buffer_create" hb_buffer_create :: IO Buffer'+foreign import ccall "hb_buffer_destroy" hb_buffer_destroy :: Buffer' -> IO ()++-- | Decodes given lazy `Text` into given `Buffer'`.+-- Should be valid Unicode data.+-- Captures a few trailing & preceding chars when possible to give additional+-- context to the shaping.+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 ()++-- | Converts initial char to uppercase & all others to lowercase.+-- Internal utility for reimplementation `script_from_string`.+titlecase :: String -> String+titlecase "" = ""+titlecase (c:cs) = toUpper c : Prelude.map toLower cs+-- | Converts a string str representing an ISO 15924 script tag to a corresponding "tag" `Word32`.+script_from_string :: String -> Word32+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+-- | Converts a `String` into a "tag" `Word32`. Valid tags are 4 `Char`s.+-- Shorter input `String`s will be padded with spaces.+-- Longer input strings will be truncated.+tag_from_string :: String -> Word32+tag_from_string str = case str ++ Prelude.repeat ' ' of+ c1:c2:c3:c4:_ -> Prelude.foldl (.|.) 0 [+ shiftL (c2w c1 .&. 0x7f) 24,+ shiftL (c2w c2 .&. 0x7f) 16,+ shiftL (c2w c3 .&. 0x7f) 8,+ shiftL (c2w c4 .&. 0x7f) 0+ ]+ _ -> 0+-- | Converts a "tag" `Word32` into a 4 `Char` `String`.+tag_to_string :: Word32 -> String+tag_to_string tag = [+ w2c (shiftR tag 24 .&. 0x7f),+ w2c (shiftR tag 16 .&. 0x7f),+ w2c (shiftR tag 8 .&. 0x7f),+ w2c (shiftR tag 0 .&. 0x7f)+ ]++c2w :: Char -> Word32+c2w = toEnum . fromEnum+w2c :: Word32 -> Char+w2c = toEnum . fromEnum++------+--- Haskell-to-C conversion+------++-- | Temporarily allocates a `Buffer'` corresponding to the given `Buffer`+-- to be processed entirely within the given callback.+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 () --- | 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'+------+--- C-to-Haskell conversion+------++-- | Holds information about the glyphs & their relation to input text.+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.+ unsafeToBreak :: Bool,+ -- ^ Indicates that if input text is broken at the beginning of the cluster+ -- this glyph is part of, then both sides need to be re-shaped,+ -- as the result might be different.+ -- On the flip side, it means that when this flag is not present,+ -- then it is safe to break the glyph-run at the beginning of this cluster,+ -- and the two sides will represent the exact same result one would get+ -- if breaking input text at the beginning of this cluster and shaping+ -- the two sides separately. This can be used to optimize paragraph layout,+ -- by avoiding re-shaping of each line after line-breaking.+ unsafeToConcat :: Bool,+ -- ^ Indicates that if input text is changed on one side of the beginning+ -- of the cluster this glyph is part of, then the shaping results for+ -- the other side might change.+ -- Note that the absence of this flag will NOT by itself mean that+ -- it IS safe to concat text. Only two pieces of text both of which+ -- clear of this flag can be concatenated safely.+ -- See https://harfbuzz.github.io/harfbuzz-hb-buffer.html#HB_GLYPH_FLAG_UNSAFE_TO_CONCAT+ -- for more details.+ safeToInsertTatweel :: Bool+ -- ^ In scripts that use elongation (Arabic, Mongolian, Syriac, etc.),+ -- this flag signifies that it is safe to insert a U+0640 TATWEEL character+ -- before this cluster for elongation.+ -- This flag does not determine the script-specific elongation places,+ -- but only when it is safe to do the elongation without interrupting text shaping.+} deriving (Show, Read, Eq)+instance Storable GlyphInfo where+ sizeOf _ = sizeOf (undefined :: Word32) * 5+ alignment _ = alignment (undefined :: Word32)+ peek ptr = do+ let ptr' :: Ptr Word32+ ptr' = castPtr ptr+ -- Ignore private fields.+ codepoint' <- ptr' `peekElemOff` 0+ mask <- ptr' `peekElemOff` 1+ cluster' <- ptr' `peekElemOff` 2+ return $ GlyphInfo codepoint' cluster' (mask `testBit` 1) (mask `testBit` 2) (mask `testBit` 3)+ poke ptr (GlyphInfo codepoint' cluster' flag1 flag2 flag3) = do+ -- Zero private fields.+ let ptr' :: Ptr Word32+ ptr' = castPtr ptr+ pokeElemOff ptr' 0 codepoint'+ pokeElemOff ptr' 1 $ Prelude.foldl (.|.) 0 [+ if flag1 then 1 else 0,+ if flag2 then 2 else 0,+ if flag3 then 4 else 0+ ]+ pokeElemOff ptr' 2 cluster'+ pokeElemOff ptr' 3 0+ pokeElemOff ptr' 4 0+-- | Decodes `Buffer'`'s glyph information array.'+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--- | 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_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. --- | 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',+-- | Holds positions of the glyph in both horizontal & vertical directions.+-- All positions are relative to current point.+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 Storable GlyphPos where+ sizeOf _ = sizeOf (undefined :: Int32) * 5+ alignment _ = alignment (undefined :: Int32)+ peek ptr = let ptr' = castPtr ptr in do+ x_advance' <- ptr' `peekElemOff` 0+ y_advance' <- ptr' `peekElemOff` 1+ x_offset' <- ptr' `peekElemOff` 2+ y_offset' <- ptr' `peekElemOff` 3+ return $ GlyphPos x_advance' y_advance' x_offset' y_offset'+ poke ptr (GlyphPos x_advance' y_advance' x_offset' y_offset') = do+ let ptr' :: Ptr Int32+ ptr' = castPtr ptr+ pokeElemOff ptr' 0 x_advance'+ pokeElemOff ptr' 1 y_advance'+ pokeElemOff ptr' 2 x_offset'+ pokeElemOff ptr' 3 y_offset'+ pokeElemOff ptr' 4 0 -- Zero private field.+-- | Decodes `Buffer'`'s glyph position array.+-- If buffer did not have positions before, they will be initialized to zeros.'+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+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.++-- | Decodes a `Buffer'` back to corresponding pure-functional `Buffer`.+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 +496,18 @@ 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
Data/Text/Glyphize/Font.hs view
@@ -1,57 +1,160 @@-{-# 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,+ c2w, w2c) +import Control.Monad (forM, unless)+import Data.Maybe (fromMaybe)+ 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 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) -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)+------+--- Features & Variants+------ -type Face = ForeignPtr Face'-type Face_ = Ptr Face'-data Face'+-- | The structure that holds information about requested feature application.+-- The feature will be applied with the given value to all glyphs which are+-- in clusters between start (inclusive) and end (exclusive).+-- Setting start to HB_FEATURE_GLOBAL_START and end to HB_FEATURE_GLOBAL_END specifies+-- that the feature always applies to the entire buffer.+data Feature = Feature {+ featTag' :: Word32,+ -- ^ Tag of the feature. Use `featTag` to decode as an ASCII string.+ featValue :: Word32,+ -- ^ The value of the feature.+ -- 0 disables the feature, non-zero (usually 1) enables the feature.+ -- For features implemented as lookup type 3 (like 'salt') the value+ -- is a one based index into the alternates.+ featStart :: Word,+ -- ^ The cluster to start applying this feature setting (inclusive).+ featEnd :: Word+ -- ^ The cluster to end applying this feature setting (exclusive).+} deriving (Read, Show, Generic)+instance GStorable Feature+-- | Parses a string into a hb_feature_t.+-- The format for specifying feature strings follows. All valid CSS+-- font-feature-settings values other than 'normal' and the global values+-- are also accepted. CSS string escapes are not supported.+-- See https://harfbuzz.github.io/harfbuzz-hb-common.html#hb-feature-from-string+-- for additional details.+-- The range indices refer to the positions between Unicode characters.+-- The position before the first character is always 0.+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+-- | Converts a `Feature` into a `String` in the format understood by `parseFeature`.+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 () -foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Word+-- | Data type for holding variation data.+-- Registered OpenType variation-axis tags are listed in+-- [OpenType Axis Tag Registry](https://docs.microsoft.com/en-us/typography/opentype/spec/dvaraxisreg).+data Variation = Variation {+ varTag' :: Word32,+ -- ^ Tag of the variation-axis name. Use `verTag` to decode as an ASCII string.+ varValue :: Float+ -- ^ Value of the variation axis.+} deriving (Read, Show, Generic)+instance GStorable Variation+-- | Parses a string into a hb_variation_t.+-- The format for specifying variation settings follows.+-- All valid CSS font-variation-settings values other than 'normal' and 'inherited'+-- are also accepted, though, not documented below.+-- The format is a tag, optionally followed by an equals sign, followed by a number.+-- For example wght=500, or slnt=-7.5.+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+-- | Converts a `Variation` into a `String` in the format understood by `parseVariation`.+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 ()++-- | Tag of the feature.+featTag = tag_to_string . featTag'+-- | Tag of the variation-axis.+varTag = tag_to_string . varTag'+globalStart, globalEnd :: Word+-- | Special setting for `featStart` to apply the feature from the start of the buffer.+globalStart = 0+-- | Special setting for `featEnd` to apply the feature to the end of the buffer.+globalEnd = maxBound++------+--- Faces+------++-- | Fetches the number of `Face`s in a `ByteString`. 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 ())+-- | A Font face.+type Face = ForeignPtr Face'+type Face_ = Ptr Face'+data Face'+-- | Constructs a new face object from the specified blob and a face index into that blob.+-- The face index is used for blobs of file formats such as TTC and and DFont that+-- can contain more than one face. Face indices within such collections are zero-based.+-- Note: If the blob font format is not a collection, index is ignored. Otherwise,+-- only the lower 16-bits of index are used. The unmodified index can be accessed+-- via hb_face_get_index().+-- Note: The high 16-bits of index, if non-zero, are used by hb_font_create() to+-- load named-instances in variable fonts. See hb_font_create() for details. 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 ()) +-- | Creates a`Face` object from the specified `FT_Face`.+-- Not thread-safe due to FreeType dependency.+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_-ftCreateFace :: FT_Face -> Face-ftCreateFace =- unsafePerformIO . newForeignPtr hb_face_destroy' . hb_ft_face_create_referenced -foreign import ccall "hb_face_get_empty" hb_face_get_empty :: Face_+-- | Fetches the singleton empty `Face` object. 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+-- | Fetches a list of all table tags for a face, if possible.+-- The list returned will begin at the offset provided 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 +162,211 @@ 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+-- | Fetches the glyph-count value of the specified face object. 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 ()+-- | Collects all of the Unicode characters covered by `Face` into a list of unique values. 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 ()+-- | Collects all Unicode "Variation Selector" characters covered by `Face`+-- into a list of unique values. 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 () +-- | Collects all Unicode characters for variation_selector covered by `Face`+-- into a list of unique values.+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+-- | Fetches the face-index corresponding to the given `Face`. 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+-- | Fetches the units-per-em (upem) value of the specified `Face` object. faceUpem :: Face -> Word faceUpem = faceFunc hb_face_get_upem+foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Word +-- | Fetches the binary blob that contains the specified `Face`.+-- Returns an empty `ByteString` if referencing face data is not possible.+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...+-- | Fetches the specified table within the specified face.+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_ ----+------+--- Configure faces+------ +-- | Allows configuring properties on a `Face` when creating it.+data FaceOptions = FaceOptions {+ faceOptGlyphCount :: Maybe Int,+ -- ^ Sets the glyph count for a newly-created `Face` to the specified value.+ faceOptIndex :: Maybe Word,+ -- ^ Assigns the specified face-index to the newly-created `Face`.+ -- Note: changing the index has no effect on the face itself,+ -- only value returned by `faceIndex`.+ faceOptUPEm :: Maybe Word+ -- ^ Sets the units-per-em (upem) for a newly-created `Face` object+ -- to the specified value.+}+-- | `FaceOptions` which has no effect on the newly-created `Face` object.+defaultFaceOptions = FaceOptions Nothing Nothing Nothing+-- | Internal utility to apply the given `FaceOptions` to a `Face`.+_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 ()++-- | Variant of `createFace` which applies given options.+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+-- | Variant of `ftCreateFace` which applies given options.+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++-- | Creates a `Face` containing the specified tables+tags, with the specified options.+-- Can be compiled to a binary font file by calling `faceBlob`,+-- with tables sorted by size then tag.+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+{-+-- | Creates a `Face` containing the specified tables+tags, with the specified options.+-- Can be compiled to a binary font file by calling `faceBlob`,+-- with tables in the given order.+buildOrderedFace :: [(String, ByteString)] -> FaceOptions -> Face+buildOrderedFace 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+ withArray (map tag_from_string $ map fst tables) $ hb_face_builder_sort_tables builder+ _setFaceOptions builder opts+ hb_face_make_immutable builder+ newForeignPtr hb_face_destroy builder+foreign import ccall "hb_face_builder_sort_tables" hb_face_builder_sort_tables+ :: Face_ -> Ptr Word32 -> IO ()-}++------+--- Fonts+------++-- | Data type for holding 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 ())+-- | Constructs a new `Font` object from the specified `Face`.+-- Note: If face's index value (as passed to `createFace` has non-zero top 16-bits,+-- those bits minus one are passed to hb_font_set_var_named_instance(),+-- effectively loading a named-instance of a variable font,+-- instead of the default-instance.+-- This allows specifying which named-instance to load by default when creating the face. 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_+-- | Creates an hb_font_t font object from the specified FT_Face.+-- Note: You must set the face size on ft_face before calling `ftCreateFont` on it.+-- HarfBuzz assumes size is always set+-- and will access `size` member of `FT_Face` unconditionally. 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_+-- | Constructs a sub-font font object from the specified parent font,+-- replicating the parent's properties.+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_++-- | Fetches the empty `Font` object. 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+-- | Fetches the `Face` associated with the specified `Font` object.+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_+ +-- | Fetches the glyph ID for a Unicode codepoint in the specified `Font`,+-- with an optional variation selector. 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 ()+-- | Fetches the advance for a glyph ID from the specified font,+-- in a text segment of the specified direction.+-- Calls the appropriate direction-specific variant (horizontal or vertical)+-- depending on the value of direction . fontGlyphAdvance :: Font -> Word32 -> Maybe Direction -> (Int32, Int32) fontGlyphAdvance font glyph dir = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do@@ -141,9 +374,12 @@ 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+-- | Fetches the (x,y) coordinates of a specified contour-point index+-- in the specified glyph, within the specified font. fontGlyphContourPoint :: Font -> Word32 -> Int -> Maybe (Int32, Int32) fontGlyphContourPoint font glyph index = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do@@ -154,10 +390,14 @@ 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+-- | Fetches the (X,Y) coordinates of a specified contour-point index+-- in the specified glyph ID in the specified font,+-- with respect to the origin in a text segment in the specified direction.+-- Calls the appropriate direction-specific variant (horizontal or vertical)+-- depending on the value of direction . 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 +409,24 @@ 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 +-- | Glyph extent values, measured in font units.+-- Note that height is negative, in coordinate systems that grow up. 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+ xBearing :: Word32,+ -- ^ Distance from the x-origin to the left extremum of the glyph.+ yBearing :: Word32,+ -- ^ Distance from the top extremum of the glyph to the y-origin.+ width :: Word32,+ -- ^ Distance from the left extremum of the glyph to the right extremum.+ height :: Word32+ -- ^ Distance from the top extremum of the glyph to the right extremum.+} deriving (Generic)+instance GStorable GlyphExtents+-- | Fetches the `GlyphExtents` data for a glyph ID in the specified `Font`. fontGlyphExtents :: Font -> Word32 -> Maybe GlyphExtents fontGlyphExtents font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do@@ -200,10 +434,13 @@ 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+-- | Fetches the `GlyphExtents` data for a glyph ID in the specified `Font`,+-- with respect to the origin in a text segment in the specified direction.+-- Calls the appropriate direction-specific variant (horizontal or vertical)+-- depending on the value of `dir`. fontGlyphExtentsForOrigin :: Font -> Word32 -> Maybe Direction -> Maybe GlyphExtents fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do@@ -211,33 +448,48 @@ 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+-- | Fetches the glyph ID that corresponds to a name string in the specified `Font`. fontGlyphFromName :: Font -> String -> Maybe Word32 fontGlyphFromName font name = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do- success <- withCString name $ \name' ->- hb_font_get_glyph_from_name font' name' (-1) ret+ 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 -foreign import ccall "hb_font_get_glyph_h_advance" hb_font_get_glyph_h_advance- :: Font_ -> Word32 -> Int32+-- | Fetches the advance for a glyph ID in the specified `Font`,+-- for horizontal text segments. 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 -foreign import ccall "hb_font_get_glyph_h_kerning" hb_font_get_glyph_h_kerning- :: Font_ -> Word32 -> Word32 -> Int32+-- | Fetches the advance for a glyph ID in the specified `Font`,+-- for vertical text segments.+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++-- | Fetches the kerning-adjustment value for a glyph-pair in the specified `Font`,+-- for horizontal text segments. 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+-- | Fetches the (X,Y) coordinate of the origin for a glyph ID in the specified `Font`,+-- for horizontal text segments. 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 +497,104 @@ 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 -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 ()+-- | Fetches the (X,Y) coordinates of the origin for a glyph ID in the specified `Font`,+-- for vertical text segments.+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++-- | Fetches the kerning-adjustment value for a glyph-pair in the specified `Font`.+-- Calls the appropriate direction-specific variant (horizontal or vertical)+-- depending on the value of `dir`. 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_kerning_for_direction"+ hb_font_get_glyph_kerning_for_direction ::+ Font_ -> Word32 -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO () -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+-- | Fetches the glyph-name string for a glyph ID in the specified `font`.+fontGlyphName :: Font -> Word32 -> Maybe String+fontGlyphName a b = fontGlyphName_ a b 32+-- | Variant of `fontGlyphName` which lets you specify the maximum of the return value.+-- Defaults to 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 ()+-- | Fetches the (X,Y) coordinates of the origin for a glyph in the specified `Font`.+-- Calls the appropriate direction-specific variant (horizontal or vertical)+-- depending on the value of `dir`. 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_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_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_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+-- | Fetches the nominal glyph ID for a Unicode codepoint in the specified font.+-- This version of the function should not be used to fetch glyph IDs for codepoints+-- modified by variation selectors. For variation-selector support use+-- `fontVarGlyph` or use `fontGlyph`. 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+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 -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+-- | Fetches the parent of the given `Font`.+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_++-- | Fetches the horizontal & vertical points-per-em (ppem) of a `Font`.+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+-- | Fetches the "point size" of a `Font`. Used in CoreText to implement optical sizing. 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 ()+-- | Fetches the horizontal and vertical scale of a `Font`. fontScale :: Font -> (Int, Int) fontScale font = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do@@ -329,9 +602,18 @@ 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 () -foreign import ccall "hb_font_get_variation_glyph" hb_font_get_variation_glyph- :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool+{-+-- | Fetches the "synthetic slant" of a font.+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-}++-- | Fetches the glyph ID for a Unicode codepoint when followed by+-- the specified variation-selector codepoint, in the specified `Font`. fontVarGlyph :: Font -> Word32 -> Word32 -> Maybe Word32 fontVarGlyph font unicode varSel = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do@@ -339,92 +621,151 @@ 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 -foreign import ccall "hb_font_get_var_coords_normalized"- hb_font_get_var_coords_normalized :: Font_ -> Ptr Word -> IO (Ptr Int)+{-+-- | Fetches the list of variation coordinates (in design-space units)+-- currently set on a `Font`.+-- Note that this returned list may only contain values for some (or none) of the axes;+-- ommitted axes effectively have their default values.+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)-}++-- | Fetches the list of normalized variation coordinates currently set on a font.+-- Note that this returned list may only contain values for some (or none) of the axes;+-- ommitted axes effectively have default values. 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+-- | Fetches the glyph ID from given `Font` that matches the specified string.+-- Strings of the format gidDDD or uniUUUU are parsed automatically. fontTxt2Glyph :: Font -> String -> Maybe Word32 fontTxt2Glyph font str = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do- ok <- withCString str $ \str' ->- hb_font_glyph_from_string font' str' (-1) ret+ 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 -foreign import ccall "hb_font_glyph_to_string" hb_font_glyph_to_string- :: Font_ -> Word32 -> CString -> Int -> IO ()+-- | Fetches the name of the specified glyph ID in given `Font` as a string.+-- If the glyph ID has no name in the `Font`, a string of the form gidDDD is generated+-- with DDD being the glyph ID. 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 () +-- | Font-wide extent values, measured in font units.+-- Note that typically ascender is positive and descender is negative,+-- in coordinate systems that grow up.+-- Note: Due to presence of 9 additional private fields,+-- arrays of font extents will not decode correctly. So far this doesn't matter. data FontExtents = FontExtents { ascender :: Int32,+ -- ^ The height of typographic ascenders. descender :: Int32,+ -- ^ The depth of typographic descenders. 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 ()+ -- ^ The suggested line-spacing gap.+} deriving (Generic)+instance GStorable FontExtents+-- | Fetches the extents for a font in a text segment of the specified direction.+-- Calls the appropriate direction-specific variant (horizontal or vertical)+-- depending on the value of direction . 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+-- | Fetches the extents for a specified font, for horizontal text segments. 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++-- | Fetches the extents for a specified font, for vertical text segments. 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 imperative with little value to callers. +------+--- Configurable fonts+------++-- | Allows configuring properties on a `Font` when creating it. data FontOptions = FontOptions { optionPPEm :: Maybe (Word, Word),+ -- ^ Sets the horizontal and vertical pixels-per-em (ppem) of the newly-created `Font`. optionPtEm :: Maybe Float,- optionScale :: Maybe (Int, Int)+ -- ^ Sets the "point size" of a newly-created `Font`.+ -- Used in CoreText to implement optical sizing.+ -- Note: There are 72 points in an inch.+ optionScale :: Maybe (Int, Int),+ -- ^ Sets the horizontal and vertical scale of a newly-created `Font`.+ optionFace :: Maybe Face,+ -- ^ Sets the font-face value of the newly-created `Font`.+ optionParent :: Maybe Font,+ -- ^ Sets the parent `Font` of the newly-created `Font`.+-- optionSynthSlant :: Maybe Float,+ -- ^ Sets the "synthetic slant" of a newly-created `Font`. By default is zero.+ -- Synthetic slant is the graphical skew applied to the font at rendering time.+ -- Harfbuzz needs to know this value to adjust shaping results, metrics,+ -- and style valuesto match the slanted rendering.+ -- Note: The slant value is a ratio. For example, a 20% slant would be+ -- represented as a 0.2 value.+ optionVariations :: [Variation],+ -- ^ Applies a list of font-variation settings to a font.+ -- Axes not included will be effectively set to their default values.+ optionVarCoordsDesign :: [Float],+ -- ^ Applies a list of variation coordinates (in design-space units)+ -- to a newly-created `Font`.+ -- Axes not included in coords will be effectively set to their default values.+ optionVarCoordsNormalized :: [Int],+ -- ^ Applies a list of variation coordinates (in normalized units)+ -- to a newly-created `Font`.+ -- Axes not included in coords will be effectively set to their default values.+ optionVarNamedInstance :: Maybe Word+ -- ^ Sets design coords of a font from a named instance index. }+-- | `FontOptions` which has no effect on the newly-created `Font`. defaultFontOptions = FontOptions {- optionPPEm = Nothing, optionPtEm = Nothing,- optionScale = Nothing+ optionPPEm = Nothing, optionPtEm = Nothing, optionScale = Nothing,+ optionFace = Nothing, optionParent = Nothing,-- optionSynthSlant = Nothing,+ optionVariations = [], optionVarCoordsDesign = [], optionVarCoordsNormalized = [],+ optionVarNamedInstance = Nothing }-+-- | Internal utility to apply the given `FontOptions` to the given `Font`. _setFontOptions font opts = do case optionPPEm opts of Just (x, y) -> hb_font_set_ppem font x y@@ -435,66 +776,127 @@ 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 ()+ {-case optionSynthSlant opts of+ Just slant -> hb_font_set_synthetic_slant font slant+ 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_synthetic_slant" hb_font_set_synthetic_slant ::+ Font_ -> Float -> 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 ()++-- | Variant of `createFont` which applies the given `FontOptions`. 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 +-- | Variant of `ftCreateFont` which applies the given `FontOptions`. 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--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 ()+ newForeignPtr hb_font_destroy font --- Defer implementation of other functions...+-- | Variant of createSubFont which applies the given `FontOptions`.+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 ----+------+--- Internal+------ +-- | Harfbuzz's equivalent to the ByteString type. 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 ()))+-- | Convert from a ByteString to Harfbuzz's equivalent.+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 ()) -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+-- | Convert to a ByteString from Harfbuzz's equivalent.+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 () +-- | Internal utility for defining trivial language bindings unwrapping `Face` foreign pointers. faceFunc :: (Face_ -> a) -> (Face -> a) faceFunc cb fce = unsafePerformIO $ withForeignPtr fce $ return . cb +-- | Internal utility for defining trivial language bindings unwrapping `Font` foreign pointers. fontFunc :: (Font_ -> a) -> (Font -> a) fontFunc cb fnt = unsafePerformIO $ withForeignPtr fnt $ return . cb +-- | Internal utility for exposing Harfbuzz functions that populate a bitset.+-- Converts the populated bitset to a Haskell lazy linked-list.+faceCollectFunc :: (Face_ -> Set_ -> IO ()) -> (Face -> [Word32])+faceCollectFunc cb fce = unsafePerformIO $ withForeignPtr fce $ \fce' -> do+ set <- createSet+ withForeignPtr set $ cb fce'+ set2list set++-- | A Harfbuzz bitset. 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 ())-+-- | Creates a Harfbuzz bitset wrapping it in a foreignpointer. 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+-- | Lazily retrieves the next codepoint in a bitset. setNext :: Set -> Word32 -> Maybe Word32 setNext set iter = unsafePerformIO $ withForeignPtr set $ \set' -> alloca $ \iter' -> do poke iter' iter@@ -502,14 +904,11 @@ if success then return . Just =<< peek iter' else return Nothing+foreign import ccall "hb_set_next" hb_set_next :: Set_ -> Ptr Word32 -> IO Bool++-- | Converts a Harfbuzz bitset into a lazy linkedlist. 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
Main.hs view
@@ -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
harfbuzz-pure.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.0+version: 0.1.0.1 -- A short (one-line) description of the package. synopsis: Pure-functional Harfbuzz language bindings@@ -60,8 +60,8 @@ -- 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,+ bytestring >= 0.11, freetype2 >= 0.2, derive-storable >= 0.3 && < 1 pkgconfig-depends: harfbuzz -- Directories containing source files.@@ -75,7 +75,7 @@ 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: .