From 843f64159ab52a8975138629765b275bc0a3a5dd Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 20 Feb 2022 20:19:01 +1300 Subject: [PATCH] Add documentation & corrected type signatures. --- Data/Text/Glyphize.hs | 78 ++++++++++--- Data/Text/Glyphize/Buffer.hs | 75 ++++++++---- Data/Text/Glyphize/Font.hs | 213 +++++++++++++++++++++++++++-------- Main.hs | 14 ++- 4 files changed, 290 insertions(+), 90 deletions(-) diff --git a/Data/Text/Glyphize.hs b/Data/Text/Glyphize.hs index 9d08f9c..c46c4ed 100644 --- a/Data/Text/Glyphize.hs +++ b/Data/Text/Glyphize.hs @@ -3,21 +3,73 @@ module Data.Text.Glyphize where import Data.Text.Glyphize.Buffer import Data.Text.Glyphize.Font +import Data.Word + import Foreign.Ptr import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Storable +import Foreign.C.String +import Control.Monad (forM) import System.IO.Unsafe (unsafePerformIO) -foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer_ -> Ptr () -> Int -> IO () +foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer_ -> Ptr Feature -> Int -> IO () + +-- | 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 = unsafePerformIO $ do - buf_ <- freeze' buf - withForeignPtr font $ \font' -> withForeignPtr buf_ $ \buf' -> - hb_shape font' buf' nullPtr 0 - infos <- glyphInfos' buf_ - pos <- glyphsPos' buf_ - return $ zip infos pos --- Defer implementing font features... - --- version :: (Int, Int, Int) --- versionAtLeast :: (Int, Int, Int) -> Bool --- versionString :: ShortString +shape font buf = shapeWithFeatures font buf [] + +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' + + poke p (Feature tag' val' start' end') = do + let q = castPtr p + poke q $ hb_tag_from_string tag' + pokeElemOff q 1 val' + let r = castPtr $ plusPtr p (sizeOf (undefined :: Word32) * 2) + poke r start' + pokeElemOff r 1 end' + +-- | Variant of `shape` specifying OpenType features to apply. +-- If two features have the same tag but overlapping ranges, the one with a +-- higher index takes precedance. +shapeWithFeatures :: Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)] +shapeWithFeatures font buf feats = unsafePerformIO $ do + 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_ + return $ zip infos pos + +foreign import ccall "hb_version" hb_version :: Ptr Int -> Ptr Int -> Ptr Int -> IO () +version :: (Int, Int, Int) +version = unsafePerformIO $ + alloca $ \a' -> alloca $ \b' -> alloca $ \c' -> do + hb_version a' b' c' + a <- peek a' + b <- peek b' + c <- peek c' + return (a, b, c) +foreign import ccall "hb_version_atleast" versionAtLeast :: Int -> Int -> Int -> Bool +foreign import ccall "hb_version_string" hb_version_string :: CString +versionString :: String +versionString = unsafePerformIO $ peekCString hb_version_string diff --git a/Data/Text/Glyphize/Buffer.hs b/Data/Text/Glyphize/Buffer.hs index 476f20f..76529a3 100644 --- a/Data/Text/Glyphize/Buffer.hs +++ b/Data/Text/Glyphize/Buffer.hs @@ -3,7 +3,7 @@ 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.Text.Short as Short +import Data.Int import Foreign.ForeignPtr import Foreign.Ptr @@ -39,11 +39,11 @@ data Buffer = Buffer { -- the direction, for example, reversing RTL text before shaping, -- then shaping with LTR direction is not the same as keeping the text in -- logical order and shaping with RTL direction. - script :: Maybe ShortText, + script :: Maybe String, -- ^ Script is crucial for choosing the proper shaping behaviour for scripts -- that require it (e.g. Arabic) and the which OpenType features defined in -- the font to be applied. - language :: Maybe ShortText, + language :: Maybe String, -- ^ Languages are crucial for selecting which OpenType feature to apply to -- the buffer which can result in applying language-specific behaviour. -- Languages are orthogonal to the scripts, and though they are related, @@ -101,7 +101,16 @@ data ClusterLevel = ClusterMonotoneGraphemes | ClusterMonotoneChars | ClusterCha 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) @@ -116,12 +125,22 @@ instance Storable GlyphInfo where pokeElemOff q 1 b data GlyphPos = GlyphPos { - x_advance :: Word32, y_advance :: Word32, - x_offset :: Word32, y_offset :: Word32 + 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 :: Word32) - alignment _ = alignment (undefined :: Word32) + sizeOf _ = 4 * sizeOf (undefined :: Int32) + alignment _ = alignment (undefined :: Int32) peek p = do q <- return $ castPtr p xa <- peek q @@ -138,9 +157,9 @@ instance Storable GlyphPos where guessSegmentProperties :: Buffer -> Buffer guessSegmentProperties = thaw . freeze -scriptHorizontalDir :: ShortText -> Maybe Direction +scriptHorizontalDir :: String -> Maybe Direction scriptHorizontalDir script = - int2dir $ hb_script_get_horizontal_direction $ hb_script_from_txt script + int2dir $ hb_script_get_horizontal_direction $ hb_script_from_string script int2dir 4 = Just DirLTR int2dir 5 = Just DirRTL @@ -168,7 +187,9 @@ type Buffer' = ForeignPtr Buffer'' data 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 @@ -183,10 +204,10 @@ freeze' buf = do Just ContentTypeGlyphs -> 2 hb_buffer_set_direction buffer $ dir2int $ direction buf case script buf of - Just script' -> hb_buffer_set_script buffer $ hb_script_from_txt script' + Just script' -> hb_buffer_set_script buffer $ hb_script_from_string script' Nothing -> return () case language buf of - Just lang' -> hb_buffer_set_language buffer =<< hb_language_from_txt lang' + Just lang' -> hb_buffer_set_language buffer =<< hb_language_from_string lang' Nothing -> return () hb_buffer_set_flags buffer $ Prelude.foldl (.|.) 0 [ if beginsText buf then 1 else 0, @@ -207,25 +228,34 @@ freeze' buf = do (Just ContentTypeUnicode, _, _, Nothing) -> hb_buffer_guess_segment_properties buffer newForeignPtr hb_buffer_destroy buffer +-- | 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' if length == 0 then return [] - else forM [0..length - 1] $ peekElemOff arr + 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 then return [] - else forM [0..length-1] $ peekElemOff arr + else forM [0..fromEnum length-1] $ peekElemOff arr +-- | 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' @@ -246,8 +276,8 @@ thaw' buf' = do 2 -> Just ContentTypeGlyphs _ -> Nothing, direction = int2dir direction', - language = Just $ Short.fromString language', - script = Just $ Short.fromString $ hb_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, @@ -298,16 +328,15 @@ hb_script_from_string str = hb_tag_from_string $ case titlecase str of 'S':'y':'r':'e':_ -> "Syrc" 'S':'y':'r':'j':_ -> "Syrc" 'S':'y':'r':'n':_ -> "Syrc" -hb_script_from_txt txt = hb_script_from_string $ Short.toString txt 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 - :: Ptr Word8 -> Int -> Int -hb_language_from_txt txt = let Strict.PS ptr offset size = toByteString txt - in withForeignPtr ptr $ \ptr' -> return $ - hb_language_from_string (plusPtr ptr' offset) (size - offset) +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 () @@ -338,9 +367,9 @@ foreign import ccall "hb_buffer_get_flags" hb_buffer_get_flags :: Buffer_ -> IO 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 Int -> IO (Ptr GlyphInfo) + :: Buffer_ -> Ptr Word -> IO (Ptr GlyphInfo) foreign import ccall "hb_buffer_get_glyph_positions" hb_buffer_get_glyph_positions - :: Buffer_ -> Ptr Int -> IO (Ptr GlyphPos) + :: Buffer_ -> Ptr Word -> IO (Ptr GlyphPos) foreign import ccall "hb_buffer_get_invisible_glyph" hb_buffer_get_invisible_glyph :: Buffer_ -> IO Word32 foreign import ccall "hb_buffer_get_replacement_codepoint" hb_buffer_get_replacement_codepoint diff --git a/Data/Text/Glyphize/Font.hs b/Data/Text/Glyphize/Font.hs index 50641f9..45294e3 100644 --- a/Data/Text/Glyphize/Font.hs +++ b/Data/Text/Glyphize/Font.hs @@ -2,9 +2,8 @@ module Data.Text.Glyphize.Font where import Data.ByteString -import Data.Text.Short import FreeType.Core.Base -import Data.Text.Glyphize.Buffer (Direction(..), dir2int) +import Data.Text.Glyphize.Buffer (Direction(..), dir2int, hb_tag_to_string) import System.IO.Unsafe (unsafePerformIO) import Foreign.Ptr @@ -26,15 +25,15 @@ type Face = ForeignPtr Face' type Face_ = Ptr Face' data Face' -foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Int -countFace :: ByteString -> Int +foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Word +countFace :: ByteString -> Word countFace bytes = unsafePerformIO $ do blob <- bs2blob bytes withForeignPtr blob hb_face_count -foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Int -> IO Face_ +foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Word -> IO Face_ foreign import ccall "&hb_face_destroy" hb_face_destroy :: FunPtr (Face_ -> IO ()) -createFace :: ByteString -> Int -> Face +createFace :: ByteString -> Word -> Face createFace bytes index = unsafePerformIO $ do blob <- bs2blob bytes face <- withForeignPtr blob $ flip hb_face_create index @@ -50,17 +49,49 @@ foreign import ccall "hb_face_get_empty" hb_face_get_empty :: Face_ emptyFace :: Face emptyFace = unsafePerformIO $ newForeignPtr hb_face_destroy hb_face_get_empty -foreign import ccall "hb_face_get_glyph_count" hb_face_get_glyph_count :: Face_ -> Int -faceGlyphCount :: Face -> Int +foreign import ccall "hb_face_get_table_tags" hb_face_get_table_tags + :: Face_ -> Word -> Ptr Word -> Ptr Word32 -> IO Word +faceTableTags :: Face -> Word -> Word -> (Word, [String]) +faceTableTags fce offs cnt = unsafePerformIO $ withForeignPtr fce $ \fce' -> do + alloca $ \cnt' -> allocaBytes (fromEnum cnt * 4) $ \arr' -> do + poke cnt' cnt + length <- hb_face_get_table_tags fce' offs cnt' arr' + cnt_ <- peek cnt' + arr <- forM [0..fromEnum cnt_-1] $ peekElemOff arr' + return (length, Prelude.map hb_tag_to_string arr) + +foreign import ccall "hb_face_get_glyph_count" hb_face_get_glyph_count :: Face_ -> Word +faceGlyphCount :: Face -> Word faceGlyphCount = faceFunc hb_face_get_glyph_count -foreign import ccall "hb_face_get_index" hb_face_get_index :: Face_ -> Int -faceIndex :: Face -> Int +foreign import ccall "hb_face_collect_unicodes" hb_face_collect_unicodes + :: Face_ -> Set_ -> IO () +faceCollectUnicodes :: Face -> [Word32] +faceCollectUnicodes = faceCollectFunc hb_face_collect_unicodes + +foreign import ccall "hb_face_collect_variation_selectors" + hb_face_collect_variation_selectors :: Face_ -> Set_ -> IO () +faceCollectVarSels :: Face -> [Word32] +faceCollectVarSels = faceCollectFunc hb_face_collect_variation_selectors + +foreign import ccall "hb_face_collect_variation_unicodes" + hb_face_collect_variation_unicodes :: Face_ -> Word32 -> Set_ -> IO () +faceCollectVarUnicodes :: Face -> Word32 -> [Word32] +faceCollectVarUnicodes fce varSel = unsafePerformIO $ withForeignPtr fce $ \fce' -> do + set <- createSet + withForeignPtr set $ hb_face_collect_variation_unicodes fce' varSel + set2list set + +foreign import ccall "hb_face_get_index" hb_face_get_index :: Face_ -> Word +faceIndex :: Face -> Word faceIndex = faceFunc hb_face_get_index -foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Int -faceUpem :: Face -> Int +foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Word +-- | units-per-em +faceUpem :: Face -> Word faceUpem = faceFunc hb_face_get_upem + + -- Defer implementation of other functions... --- @@ -142,8 +173,8 @@ data GlyphExtents = GlyphExtents { width :: Word32, height :: Word32 } instance Storable GlyphExtents where - sizeOf (GlyphExtents a _ _ _) = 4 * sizeOf a - alignment (GlyphExtents a _ _ _) = alignment a + sizeOf _ = 4 * sizeOf (undefined :: Word32) + alignment _ = alignment (undefined :: Word32) peek p = do q <- return $ castPtr p x <- peek q @@ -180,30 +211,29 @@ fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $ else return Nothing foreign import ccall "hb_font_get_glyph_from_name" hb_font_get_glyph_from_name - :: Font_ -> Ptr Word8 -> Int -> Ptr Word32 -> IO Bool -fontGlyphFromName :: Font -> ShortText -> Maybe Word32 + :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool +fontGlyphFromName :: Font -> String -> Maybe Word32 fontGlyphFromName font name = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do - let PS ptr offset size = toByteString name - success <- withForeignPtr ptr $ \ptr' -> - hb_font_get_glyph_from_name font' (plusPtr ptr' offset) (size - offset) ret + success <- withCString name $ \name' -> + hb_font_get_glyph_from_name font' name' (-1) ret if success then return . Just =<< peek ret else return Nothing foreign import ccall "hb_font_get_glyph_h_advance" hb_font_get_glyph_h_advance - :: Font_ -> Word32 -> Word32 -fontGlyphHAdvance :: Font -> Word32 -> Word32 + :: Font_ -> Word32 -> Int32 +fontGlyphHAdvance :: Font -> Word32 -> Int32 fontGlyphHAdvance = fontFunc hb_font_get_glyph_h_advance foreign import ccall "hb_font_get_glyph_h_kerning" hb_font_get_glyph_h_kerning - :: Font_ -> Word32 -> Word32 -> Word32 -fontGlyphHKerning :: Font -> Word32 -> Word32 -> Word32 + :: Font_ -> Word32 -> Word32 -> Int32 +fontGlyphHKerning :: Font -> Word32 -> Word32 -> Int32 fontGlyphHKerning = fontFunc hb_font_get_glyph_h_kerning foreign import ccall "hb_font_get_glyph_h_origin" hb_font_get_glyph_h_origin - :: Font_ -> Word32 -> Ptr Word32 -> Ptr Word32 -> IO Bool -fontGlyphHOrigin :: Font -> Word32 -> Maybe (Word32, Word32) + :: Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool +fontGlyphHOrigin :: Font -> Word32 -> Maybe (Int32, Int32) fontGlyphHOrigin font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do success <- hb_font_get_glyph_h_origin font' glyph x' y' @@ -216,8 +246,8 @@ fontGlyphHOrigin font glyph = unsafePerformIO $ foreign import ccall "hb_font_get_glyph_kerning_for_direction" hb_font_get_glyph_kerning_for_direction - :: Font_ -> Word32 -> Word32 -> Int -> Ptr Word32 -> Ptr Word32 -> IO () -fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Word32, Word32) + :: Font_ -> Word32 -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO () +fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Int32, Int32) fontGlyphKerningForDir font glyph1 glyph2 dir = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_glyph_kerning_for_direction font' glyph1 glyph2 (dir2int dir) x' y' @@ -226,10 +256,10 @@ fontGlyphKerningForDir font glyph1 glyph2 dir = unsafePerformIO $ return (x, y) foreign import ccall "hb_font_get_glyph_name" hb_font_get_glyph_name - :: Font_ -> Word32 -> CString -> Int -> IO Bool -fontGlyphName :: Font -> Word32 -> Int -> Maybe String -fontGlyphName font glyph length = unsafePerformIO $ - withForeignPtr font $ \font' -> allocaBytes length $ \ret -> do + :: 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 if success then return . Just =<< peekCString ret @@ -237,8 +267,8 @@ fontGlyphName font glyph length = unsafePerformIO $ foreign import ccall "hb_font_get_glyph_origin_for_direction" hb_font_get_glyph_origin_for_direction - :: Font_ -> Word32 -> Int -> Ptr Word32 -> Ptr Word32 -> IO () -fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Word32, Word32) + :: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO () +fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Int32, Int32) fontGlyphOriginForDir font glyph dir = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_glyph_origin_for_direction font' glyph (dir2int dir) x' y' @@ -247,13 +277,13 @@ fontGlyphOriginForDir font glyph dir = unsafePerformIO $ return (x, y) foreign import ccall "hb_font_get_glyph_v_advance" - hb_font_get_glyph_v_advance :: Font_ -> Word32 -> Word32 -fontGlyphVAdvance :: Font -> Word32 -> Word32 + hb_font_get_glyph_v_advance :: Font_ -> Word32 -> Int32 +fontGlyphVAdvance :: Font -> Word32 -> Int32 fontGlyphVAdvance = fontFunc hb_font_get_glyph_v_advance foreign import ccall "hb_font_get_glyph_v_origin" hb_font_get_glyph_v_origin - :: Font_ -> Word32 -> Ptr Word32 -> Ptr Word32 -> IO Bool -fontGlyphVOrigin :: Font -> Word32 -> Maybe (Word32, Word32) + :: 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' @@ -275,8 +305,8 @@ fontNominalGlyph font char = unsafePerformIO $ else return Nothing foreign import ccall "hb_font_get_ppem" hb_font_get_ppem - :: Font_ -> Ptr Int -> Ptr Int -> IO () -fontPPEm :: Font -> (Int, Int) + :: Font_ -> Ptr Word -> Ptr Word -> IO () +fontPPEm :: Font -> (Word, Word) fontPPEm font = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_ppem font' x' y' @@ -298,23 +328,32 @@ fontScale font = unsafePerformIO $ y <- peek y' return (x, y) +foreign import ccall "hb_font_get_variation_glyph" hb_font_get_variation_glyph + :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool +fontVarGlyph :: Font -> Word32 -> Word32 -> Maybe Word32 +fontVarGlyph font unicode varSel = unsafePerformIO $ + withForeignPtr font $ \font' -> alloca $ \glyph' -> do + success <- hb_font_get_variation_glyph font' unicode varSel glyph' + if success + then return . Just =<< peek glyph' + else return Nothing + foreign import ccall "hb_font_get_var_coords_normalized" - hb_font_get_var_coords_normalized :: Font_ -> Ptr Int -> IO (Ptr Int) + hb_font_get_var_coords_normalized :: Font_ -> Ptr Word -> IO (Ptr Int) fontVarCoordsNormalized :: Font -> [Int] fontVarCoordsNormalized font = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \length' -> do arr <- hb_font_get_var_coords_normalized font' length' length <- peek length' - forM [0..length-1] $ peekElemOff arr + forM [0..fromEnum length-1] $ peekElemOff arr foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string - :: Font_ -> Ptr Word8 -> Int -> Ptr Word32 -> IO Bool -fontTxt2Glyph :: Font -> ShortText -> Maybe Word32 -fontTxt2Glyph font txt = unsafePerformIO $ + :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool +fontTxt2Glyph :: Font -> String -> Maybe Word32 +fontTxt2Glyph font str = unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do - let PS ptr offset size = toByteString txt - ok <- withForeignPtr ptr $ \ptr' -> - hb_font_glyph_from_string font' (plusPtr ptr' offset) (size - offset) ret + ok <- withCString str $ \str' -> + hb_font_glyph_from_string font' str' (-1) ret if ok then return . Just =<< peek ret else return Nothing @@ -327,10 +366,55 @@ fontGlyph2Str font glyph length = unsafePerformIO $ hb_font_glyph_to_string font' glyph ret length peekCString ret +data FontExtents = FontExtents { + ascender :: Int32, + descender :: Int32, + lineGap :: Int32 +} + +instance Storable FontExtents where + sizeOf _ = sizeOf (undefined :: Int32) * 3 + alignment _ = alignment (undefined :: Int32) + peek p = do + let q = castPtr p + asc <- peek q + desc <- peekElemOff q 1 + gap <- peekElemOff q 2 + return $ FontExtents asc desc gap + poke p (FontExtents asc desc gap) = do + let q = castPtr p + poke q asc + pokeElemOff q 1 desc + pokeElemOff q 2 gap + +foreign import ccall "hb_font_get_extents_for_direction" + hb_font_get_extents_for_direction :: Font_ -> Int -> Ptr FontExtents -> IO () +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_h_extents" hb_font_get_h_extents + :: Font_ -> Ptr FontExtents -> IO Bool +fontHExtents font = unsafePerformIO $ alloca $ \ret -> do + ok <- withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret + if ok + then return . Just =<< peek ret + else return Nothing + +foreign import ccall "hb_font_get_v_extents" hb_font_get_v_extents + :: Font_ -> Ptr FontExtents -> IO Bool +fontVExtents font = unsafePerformIO $ alloca $ \ret -> do + ok <- withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret + if ok + then return . Just =<< peek ret + else return Nothing + --- data FontOptions = FontOptions { - optionPPEm :: Maybe (Int, Int), + optionPPEm :: Maybe (Word, Word), optionPtEm :: Maybe Float, optionScale :: Maybe (Int, Int) } @@ -364,7 +448,7 @@ ftCreateFontWithOptions opts fce = unsafePerformIO $ do hb_font_make_immutable font newForeignPtr hb_font_destroy font -foreign import ccall "hb_font_set_ppem" hb_font_set_ppem :: Font_ -> Int -> Int -> IO () +foreign import ccall "hb_font_set_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 () @@ -396,3 +480,34 @@ faceFunc cb fce = unsafePerformIO $ withForeignPtr fce $ return . cb fontFunc :: (Font_ -> a) -> (Font -> a) fontFunc cb fnt = unsafePerformIO $ withForeignPtr fnt $ return . cb + +data Set' +type Set = ForeignPtr Set' +type Set_ = Ptr Set' +foreign import ccall "hb_set_create" hb_set_create :: IO Set_ +foreign import ccall "&hb_set_destroy" hb_set_destroy :: FunPtr (Set_ -> IO ()) + +createSet :: IO Set +createSet = do + ret <- hb_set_create + newForeignPtr hb_set_destroy ret + +foreign import ccall "hb_set_next" hb_set_next :: Set_ -> Ptr Word32 -> IO Bool +setNext :: Set -> Word32 -> Maybe Word32 +setNext set iter = unsafePerformIO $ withForeignPtr set $ \set' -> alloca $ \iter' -> do + poke iter' iter + success <- hb_set_next set' iter' + if success + then return . Just =<< peek iter' + else return Nothing +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 index 23ed016..b4919fc 100644 --- a/Main.hs +++ b/Main.hs @@ -6,6 +6,8 @@ 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 @@ -17,9 +19,11 @@ shapeStr font word = shape font $ defaultBuffer { main :: IO () main = do - print $ guessSegmentProperties $ defaultBuffer { text = Right "Testing, testing"} - + print versionString words <- getArgs - blob <- BS.readFile "assets/Lora-Regular.ttf" - let font = createFont $ createFace blob 0 - print $ Prelude.map (shapeStr font) words + if Prelude.null words + then print $ guessSegmentProperties $ defaultBuffer { text = Right "Testing, testing"} + else do + blob <- BS.readFile "assets/Lora-Regular.ttf" + let font = createFont $ createFace blob 0 + print $ parMap rpar (shapeStr font) words -- 2.30.2