diff --git a/Data/Text/Glyphize.hs b/Data/Text/Glyphize.hs --- a/Data/Text/Glyphize.hs +++ b/Data/Text/Glyphize.hs @@ -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 diff --git a/Data/Text/Glyphize/Buffer.hs b/Data/Text/Glyphize/Buffer.hs --- a/Data/Text/Glyphize/Buffer.hs +++ b/Data/Text/Glyphize/Buffer.hs @@ -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 diff --git a/Data/Text/Glyphize/Font.hs b/Data/Text/Glyphize/Font.hs --- a/Data/Text/Glyphize/Font.hs +++ b/Data/Text/Glyphize/Font.hs @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/harfbuzz-pure.cabal b/harfbuzz-pure.cabal --- a/harfbuzz-pure.cabal +++ b/harfbuzz-pure.cabal @@ -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: .