From 5b7beb1fa0df5d230a736b8a7eda0fd0d66ef854 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <alcinnz@lavabit.com>
Date: Thu, 17 Feb 2022 20:29:00 +1300
Subject: [PATCH] Add, test, & fix shaping function.

---
 Data/Text/Glyphize.hs        | 14 ++++++-
 Data/Text/Glyphize/Buffer.hs | 70 +++++++++++++++++---------------
 Data/Text/Glyphize/Font.hs   | 78 +++++++++++-------------------------
 Main.hs                      | 21 ++++++++--
 harfbuzz-pure.cabal          |  2 +-
 5 files changed, 91 insertions(+), 94 deletions(-)

diff --git a/Data/Text/Glyphize.hs b/Data/Text/Glyphize.hs
index c86b05b..9d08f9c 100644
--- a/Data/Text/Glyphize.hs
+++ b/Data/Text/Glyphize.hs
@@ -3,9 +3,19 @@ module Data.Text.Glyphize where
 import Data.Text.Glyphize.Buffer
 import Data.Text.Glyphize.Font
 
--- Don't think I'll implement shapeplans at this stage...
--- shape :: Font -> Buffer -> [(GlyphInfo, GlyphPos)]
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import System.IO.Unsafe (unsafePerformIO)
 
+foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer_ -> Ptr () -> Int -> IO ()
+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)
diff --git a/Data/Text/Glyphize/Buffer.hs b/Data/Text/Glyphize/Buffer.hs
index 2eabaf0..476f20f 100644
--- a/Data/Text/Glyphize/Buffer.hs
+++ b/Data/Text/Glyphize/Buffer.hs
@@ -102,14 +102,13 @@ data ClusterLevel = ClusterMonotoneGraphemes | ClusterMonotoneChars | ClusterCha
 data GlyphInfo = GlyphInfo {
     codepoint :: Word32,
     cluster :: Word32
-}
+} deriving (Show, Read, Eq)
 instance Storable GlyphInfo where
-    sizeOf (GlyphInfo a b) = sizeOf a + sizeOf b
-    alignment (GlyphInfo a b) = alignment a
+    sizeOf _ = 2 * sizeOf (undefined :: Word32)
+    alignment _ = alignment (undefined :: Word32)
     peek p = do
-        q <- return $ castPtr p
-        codepoint' <- peek q
-        cluster' <- peekElemOff q 1
+        codepoint' <- peek $ castPtr p
+        cluster' <- peekElemOff (castPtr p) 1
         return $ GlyphInfo codepoint' cluster'
     poke p (GlyphInfo a b) = do
         q <- return $ castPtr p
@@ -119,10 +118,10 @@ instance Storable GlyphInfo where
 data GlyphPos = GlyphPos {
     x_advance :: Word32, y_advance :: Word32,
     x_offset :: Word32, y_offset :: Word32
-}
+} deriving (Show, Read, Eq)
 instance Storable GlyphPos where
-    sizeOf (GlyphPos a _ _ _) = 4 * sizeOf a
-    alignment (GlyphPos a _ _ _) = alignment a
+    sizeOf _ = 4 * sizeOf (undefined :: Word32)
+    alignment _ = alignment (undefined :: Word32)
     peek p = do
         q <- return $ castPtr p
         xa <- peek q
@@ -167,6 +166,7 @@ dirVertical dir = dir `Prelude.elem` [DirTTB, DirBTT]
 
 type Buffer' = ForeignPtr Buffer''
 data Buffer''
+type Buffer_ = Ptr Buffer''
 
 freeze = unsafePerformIO . freeze'
 freeze' buf = do
@@ -213,12 +213,16 @@ glyphInfos' :: Buffer' -> IO [GlyphInfo]
 glyphInfos' buf' = alloca $ \length' -> do
     arr <- withForeignPtr buf' $ \buf'' -> hb_buffer_get_glyph_infos buf'' length'
     length <- peek length'
-    forM [0..length - 1] $ peekElemOff arr
+    if length == 0
+    then return []
+    else forM [0..length - 1] $ peekElemOff arr
 glyphsPos = unsafePerformIO . glyphsPos'
 glyphsPos' buf' = alloca $ \length' -> do
       arr <- withForeignPtr buf' $ \buf'' -> hb_buffer_get_glyph_positions buf'' length'
       length <- peek length'
-      forM [0..length-1] $ peekElemOff arr
+      if length == 0
+      then return []
+      else forM [0..length-1] $ peekElemOff arr
 
 thaw :: Buffer' -> Buffer
 thaw = unsafePerformIO . thaw'
@@ -255,18 +259,18 @@ thaw' buf' = do
         invisibleGlyph = w2c invisibleGlyph', replacementCodepoint = w2c replacementCodepoint'
       }
 
-foreign import ccall "hb_buffer_create" hb_buffer_create :: IO (Ptr Buffer'')
-foreign import ccall "&hb_buffer_destroy" hb_buffer_destroy :: FunPtr (Ptr Buffer'' -> IO ())
+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
-    :: Ptr Buffer'' -> Ptr Word8 -> Int -> Int -> Int -> IO ()
+    :: 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
-    :: Ptr Buffer'' -> Int -> IO ()
+    :: Buffer_ -> Int -> IO ()
 foreign import ccall "hb_buffer_set_direction" hb_buffer_set_direction
-    :: Ptr Buffer'' -> Int -> IO ()
+    :: 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 [
@@ -296,7 +300,7 @@ hb_script_from_string str = hb_tag_from_string $ case titlecase str of
     '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
-    :: Ptr Buffer'' -> Word32 -> IO ()
+    :: 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
@@ -305,22 +309,22 @@ 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_buffer_set_language" hb_buffer_set_language
-    :: Ptr Buffer'' -> Int -> IO ()
-foreign import ccall "hb_buffer_set_flags" hb_buffer_set_flags :: Ptr Buffer'' -> Int -> IO ()
+    :: 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
-    :: Ptr Buffer'' -> Int -> IO ()
+    :: Buffer_ -> Int -> IO ()
 foreign import ccall "hb_buffer_set_invisible_glyph" hb_buffer_set_invisible_glyph
-    :: Ptr Buffer'' -> Word32 -> IO ()
+    :: Buffer_ -> Word32 -> IO ()
 foreign import ccall "hb_buffer_set_replacement_codepoint" hb_buffer_set_replacement_codepoint
-    :: Ptr Buffer'' -> Word32 -> IO ()
+    :: Buffer_ -> Word32 -> IO ()
 foreign import ccall "hb_buffer_guess_segment_properties" hb_buffer_guess_segment_properties
-    :: Ptr Buffer'' -> IO ()
+    :: Buffer_ -> IO ()
 
 
 foreign import ccall "hb_buffer_get_content_type" hb_buffer_get_content_type
-    :: Ptr Buffer'' -> IO Int
-foreign import ccall "hb_buffer_get_direction" hb_buffer_get_direction :: Ptr Buffer'' -> IO Int
-foreign import ccall "hb_buffer_get_script" hb_buffer_get_script :: Ptr Buffer'' -> IO Word32
+    :: 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),
@@ -328,16 +332,16 @@ hb_tag_to_string tag = [
     w2c (shiftR tag 8 .&. 0x7),
     w2c (shiftR tag 0 .&. 0x7)
   ]
-foreign import ccall "hb_buffer_get_language" hb_buffer_get_language :: Ptr Buffer'' -> IO (Ptr ())
+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 :: Ptr Buffer'' -> IO Int
+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
-    :: Ptr Buffer'' -> IO Int
+    :: Buffer_ -> IO Int
 foreign import ccall "hb_buffer_get_glyph_infos" hb_buffer_get_glyph_infos
-    :: Ptr Buffer'' -> Ptr Int -> IO (Ptr GlyphInfo)
+    :: Buffer_ -> Ptr Int -> IO (Ptr GlyphInfo)
 foreign import ccall "hb_buffer_get_glyph_positions" hb_buffer_get_glyph_positions
-    :: Ptr Buffer'' -> Ptr Int -> IO (Ptr GlyphPos)
+    :: Buffer_ -> Ptr Int -> IO (Ptr GlyphPos)
 foreign import ccall "hb_buffer_get_invisible_glyph" hb_buffer_get_invisible_glyph
-    :: Ptr Buffer'' -> IO Word32
+    :: Buffer_ -> IO Word32
 foreign import ccall "hb_buffer_get_replacement_codepoint" hb_buffer_get_replacement_codepoint
-    :: Ptr Buffer'' -> IO Word32
+    :: Buffer_ -> IO Word32
diff --git a/Data/Text/Glyphize/Font.hs b/Data/Text/Glyphize/Font.hs
index af014c4..50641f9 100644
--- a/Data/Text/Glyphize/Font.hs
+++ b/Data/Text/Glyphize/Font.hs
@@ -3,13 +3,14 @@ module Data.Text.Glyphize.Font where
 
 import Data.ByteString
 import Data.Text.Short
---import FreeType.Core.Base
+import FreeType.Core.Base
 import Data.Text.Glyphize.Buffer (Direction(..), dir2int)
 
 import System.IO.Unsafe (unsafePerformIO)
 import Foreign.Ptr
 import Foreign.StablePtr
 import Foreign.ForeignPtr
+import qualified Foreign.Concurrent as Conc
 import Foreign.Marshal.Alloc
 import Foreign.Storable
 import Foreign.C.String
@@ -39,11 +40,11 @@ createFace bytes index = unsafePerformIO $ do
     face <- withForeignPtr blob $ flip hb_face_create index
     newForeignPtr hb_face_destroy face
 
---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_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_
 emptyFace :: Face
@@ -77,13 +78,13 @@ createFont fce = unsafePerformIO $ do
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font
 
---foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced
---    :: FT_Face -> IO Face_
--- ftCreateFont :: FT_Face -> IO Font
--- ftCreateFont fce = unsafePerformIO $ do
---    font <- hb_ft_font_create_referenced
---    hb_font_make_immutable font
---    newForeignPtr hb_font_destroy font
+foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced
+    :: FT_Face -> IO Font_
+ftCreateFont :: FT_Face -> IO Font
+ftCreateFont fce = do
+    font <- hb_ft_font_create_referenced fce
+    hb_font_make_immutable font
+    newForeignPtr hb_font_destroy font
 
 foreign import ccall "hb_font_get_empty" hb_font_get_empty :: Font_
 emptyFont :: Font
@@ -297,30 +298,6 @@ fontScale font = unsafePerformIO $
         y <- peek y'
         return (x, y)
 
-foreign import ccall "hb_font_get_synthetic_slant" hb_font_get_synthetic_slant
-    :: Font_ -> Float
-fontSynthSlant :: Font -> Float
-fontSynthSlant = fontFunc hb_font_get_synthetic_slant
-
-foreign import ccall "hb_font_get_variance_glyph" hb_font_get_variance_glyph
-    :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
-fontVarianceGlyph :: Font -> Word32 -> Word32 -> Maybe Word32
-fontVarianceGlyph font glyph1 glyph2 = unsafePerformIO $
-    withForeignPtr font $ \font' -> alloca $ \ret -> do
-        success <- hb_font_get_variance_glyph font' glyph1 glyph2 ret
-        if success
-        then return . Just =<< peek ret
-        else return Nothing
-
-foreign import ccall "hb_font_get_var_coords_design" hb_font_get_var_coords_design
-    :: Font_ -> Ptr Int -> IO (Ptr Float)
-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..length-1] $ peekElemOff arr
-
 foreign import ccall "hb_font_get_var_coords_normalized"
     hb_font_get_var_coords_normalized :: Font_ -> Ptr Int -> IO (Ptr Int)
 fontVarCoordsNormalized :: Font -> [Int]
@@ -355,13 +332,11 @@ fontGlyph2Str font glyph length = unsafePerformIO $
 data FontOptions = FontOptions {
     optionPPEm :: Maybe (Int, Int),
     optionPtEm :: Maybe Float,
-    optionScale :: Maybe (Int, Int),
-    optionSynthSlant :: Maybe Float
+    optionScale :: Maybe (Int, Int)
 }
 defaultFontOptions = FontOptions {
     optionPPEm = Nothing, optionPtEm = Nothing,
-    optionScale = Nothing,
-    optionSynthSlant = Nothing
+    optionScale = Nothing
 }
 
 _setFontOptions font opts = do
@@ -374,9 +349,6 @@ _setFontOptions font opts = do
     case optionScale opts of
         Just (x, y) -> hb_font_set_scale font x y
         Nothing -> return ()
-    case optionSynthSlant opts of
-        Just slant -> hb_font_set_synthetic_slant font slant
-        Nothing -> return ()
 
 createFontWithOptions :: FontOptions -> Face -> Font
 createFontWithOptions opts fce = unsafePerformIO $ do
@@ -385,18 +357,16 @@ createFontWithOptions opts fce = unsafePerformIO $ do
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font
 
---ftCreateFontWithOptiosn :: FontOptions -> FT_Face -> Font
---ftCreateFontWithOptions opts fce = unsafePerformIO $ do
---    font <- hb_ft_font_create_referenced
---    _setFontOptions font opts
---    hb_font_make_immutable font
---    newForeignPtr hb_font_destroy font
+ftCreateFontWithOptions :: FontOptions -> FT_Face -> Font
+ftCreateFontWithOptions opts fce = unsafePerformIO $ do
+    font <- hb_ft_font_create_referenced fce
+    _setFontOptions font opts
+    hb_font_make_immutable font
+    newForeignPtr hb_font_destroy font
 
 foreign import ccall "hb_font_set_ppem" hb_font_set_ppem :: Font_ -> Int -> Int -> 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_synthetic_slant" hb_font_set_synthetic_slant
-    :: Font_ -> Float -> IO ()
 
 -- Defer implementation of other functions...
 
@@ -409,7 +379,7 @@ 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 :: FunPtr (Blob_ -> IO ())
+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 ()))
 
@@ -419,7 +389,7 @@ bs2blob bytes@(PS ptr offset length) = do
     blob <- withForeignPtr ptr $ \ptr' ->
         hb_blob_create (plusPtr ptr' offset) (length - offset)
             hb_MEMORY_MODE_READONLY bytes' destructor
-    newForeignPtr hb_blob_destroy blob
+    Conc.newForeignPtr blob $ hb_blob_destroy blob
 
 faceFunc :: (Face_ -> a) -> (Face -> a)
 faceFunc cb fce = unsafePerformIO $ withForeignPtr fce $ return . cb
diff --git a/Main.hs b/Main.hs
index 3409339..23ed016 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,12 +1,25 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE 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 System.Environment
+import Data.ByteString.Lazy as LBS
+import Data.ByteString as BS
+import Data.ByteString.Char8 as UTF8
+
+shapeStr font word = shape font $ defaultBuffer {
+    text = Right $ LBS.fromStrict $ UTF8.pack word
+  }
 
 main :: IO ()
 main = do
-    buf' <- freeze' defaultBuffer
-    buf <- thaw' buf'
-    print buf
-    -- TODO test I can shape text!
+    print $ guessSegmentProperties $ defaultBuffer { text = Right "Testing, testing"}
+
+    words <- getArgs
+    blob <- BS.readFile "assets/Lora-Regular.ttf"
+    let font = createFont $ createFace blob 0
+    print $ Prelude.map (shapeStr font) words
diff --git a/harfbuzz-pure.cabal b/harfbuzz-pure.cabal
index be318fa..b0badbf 100644
--- a/harfbuzz-pure.cabal
+++ b/harfbuzz-pure.cabal
@@ -75,7 +75,7 @@ executable shape-text
   main-is:             Main.hs
 
   -- Other library packages from which modules are imported
-  build-depends:       base >=4.9 && <5, harfbuzz-pure
+  build-depends:       base >=4.9 && <5, harfbuzz-pure, parallel, bytestring
 
   -- Directories containing source files.
   hs-source-dirs:      .
-- 
2.30.2