packages feed

harfbuzz-pure 1.0.3.2 → 1.0.4.0

raw patch · 7 files changed

+269/−118 lines, 7 filesdep +criteriondep +deepseqdep +file-embeddep ~basedep ~paralleldep ~textnew-component:exe:benchmark-harfbuzzPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion, deepseq, file-embed, filepath

Dependency ranges changed: base, parallel, text

API changes (from Hackage documentation)

+ Data.Text.Glyphize.Array: accursedUnutterablePerformIO :: IO a -> a
+ Data.Text.Glyphize.Array: chunkSize :: Int
+ Data.Text.Glyphize.Array: clonePtr :: Storable a => Ptr a -> Int -> IO (ForeignPtr a)
+ Data.Text.Glyphize.Array: iterateLazy :: Storable a => Ptr a -> Int -> IO [a]
+ Data.Text.Glyphize.Array: noCache :: (a -> b) -> a -> b
+ Data.Text.Glyphize.Array: peekEager :: Storable a => [a] -> Int -> Ptr a -> IO [a]
+ Data.Text.Glyphize.Array: peekLazy :: Storable a => ForeignPtr a -> Int -> [a]
- Data.Text.Glyphize: dirToStr :: Direction -> [Char]
+ Data.Text.Glyphize: dirToStr :: Direction -> String

Files

Data/Text/Glyphize.hs view
@@ -32,8 +32,9 @@ import Data.Text.Glyphize.Font import Data.Text.Glyphize.Buffer import Data.Text.Glyphize.Oom+import Data.Text.Glyphize.Array (noCache) -import System.IO.Unsafe (unsafePerformIO)+import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import Foreign.Ptr (Ptr(..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Alloc (alloca)@@ -49,12 +50,12 @@ -- the value of the `Feature` with the higher index takes precedance. shape :: Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)] shape _ Buffer {text = ""} _ = []-shape font buffer features = unsafePerformIO $ withForeignPtr font $ \font' ->-    withBuffer buffer $ \buffer' -> withArrayLen features $ \len features' -> do+shape font buffer features = unsafePerformIO $ withBuffer buffer $ \buffer' -> do+    withForeignPtr font $ \font' -> withArrayLen features $ \len features' ->         hb_shape font' buffer' features' $ toEnum len-        infos <- glyphInfos buffer'-        pos <- glyphsPos buffer'-        return $ zip infos pos+    infos <- glyphInfos buffer'+    pos <- glyphsPos buffer'+    return $ noCache zip infos pos foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer' -> Ptr Feature -> Word -> IO ()  -- | Fills in unset segment properties based on buffer unicode contents.@@ -76,7 +77,7 @@ 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 $+version = unsafeDupablePerformIO $     alloca $ \a' -> alloca $ \b' -> alloca $ \c' -> do         hb_version a' b' c'         a <- peek a'@@ -88,4 +89,4 @@ 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+versionString = unsafeDupablePerformIO $ peekCString hb_version_string
+ Data/Text/Glyphize/Array.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}+-- | Published almost entirely for benchmarks, comparing to stdlib!+-- Should have little direct interest to Harfbuzz callers, & I'm not promising a stable API.+-- This is here because, as it turns out, Harfbuzz can return a lot of output!+module Data.Text.Glyphize.Array where++import Foreign.Storable (Storable(..))+import Foreign.ForeignPtr (ForeignPtr, plusForeignPtr, withForeignPtr, mallocForeignPtrArray)+import Foreign.Ptr+import Foreign.Marshal.Array (copyArray)++import GHC.IO (IO(IO))+import GHC.Exts (realWorld#, oneShot)++-- | Clone the given array so it can be freed without the losing access to the data.+-- Uses `memcpy` so it gets very heavily optimized by the OS.+clonePtr :: Storable a => Ptr a -> Int -> IO (ForeignPtr a)+clonePtr ptr l = do+    ret <- mallocForeignPtrArray l+    withForeignPtr ret $ \ptr' -> copyArray ptr' ptr l+    return ret+-- | Iterate over an array in a ForeignPtr, no matter how small or large it is.+peekLazy :: Storable a => ForeignPtr a -> Int -> [a]+peekLazy fp 0 = []+peekLazy fp n+    | n <= chunkSize = withFP $ peekEager [] n+    | otherwise = withFP $ peekEager (plusForeignPtr fp chunkSize `peekLazy` (-) n chunkSize) chunkSize+  where withFP = accursedUnutterablePerformIO . withForeignPtr fp+-- | Variation of peekArray, taking a tail to append to the decoded list.+peekEager :: Storable a => [a] -> Int -> Ptr a -> IO [a]+peekEager acc 0 ptr = return acc+peekEager acc n ptr = let n' = pred n in do+    e <- peekElemOff ptr n'+    peekEager (e:acc) n' ptr+-- | How many words should be decoded by `peekLazy` & `iterateLazy`.+chunkSize :: Int+chunkSize = 1024 -- 4k, benchmarks seem to like it!+-- | Convert an array from C code into a Haskell list,+-- performant no matter how small or large it is.+iterateLazy :: Storable a => Ptr a -> Int -> IO [a]+iterateLazy ptr l+  | l < 0 = putStrLn ("Invalid array length: " ++ show l) >> return []+  | l == 0 = return []+  | otherwise = do+    fp <- clonePtr ptr l+    return $ noCache peekLazy fp $ fromEnum l++-- | This \"function\" has a superficial similarity to 'System.IO.Unsafe.unsafePerformIO' but+-- it is in fact a malevolent agent of chaos. It unpicks the seams of reality+-- (and the 'IO' monad) so that the normal rules no longer apply. It lulls you+-- into thinking it is reasonable, but when you are not looking it stabs you+-- in the back and aliases all of your mutable buffers. The carcass of many a+-- seasoned Haskell programmer lie strewn at its feet.+--+-- Witness the trail of destruction:+--+-- * <https://github.com/haskell/bytestring/commit/71c4b438c675aa360c79d79acc9a491e7bbc26e7>+--+-- * <https://github.com/haskell/bytestring/commit/210c656390ae617d9ee3b8bcff5c88dd17cef8da>+--+-- * <https://github.com/haskell/aeson/commit/720b857e2e0acf2edc4f5512f2b217a89449a89d>+--+-- * <https://ghc.haskell.org/trac/ghc/ticket/3486>+--+-- * <https://ghc.haskell.org/trac/ghc/ticket/3487>+--+-- * <https://ghc.haskell.org/trac/ghc/ticket/7270>+--+-- * <https://gitlab.haskell.org/ghc/ghc/-/issues/22204>+--+-- Do not talk about \"safe\"! You do not know what is safe!+--+-- Yield not to its blasphemous call! Flee traveller! Flee or you will be+-- corrupted and devoured!+--+{-# INLINE accursedUnutterablePerformIO #-}+accursedUnutterablePerformIO :: IO a -> a+accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r++-- | Harfbuzz produces ~40x as much output data as its input data.+-- In many applications that input data would be a large fraction of its heap.+-- As such, unless callers are processing these results, it is usually more+-- efficient for Haskell to recompute the glyphs than to store them.+--+-- This synonym of `oneShot` is used to instruct Haskell of this fact.+noCache :: (a -> b) -> a -> b+noCache = oneShot
Data/Text/Glyphize/Buffer.hs view
@@ -7,8 +7,10 @@ import Data.Char (toUpper, toLower) import Control.Monad (forM) import Control.Exception (bracket)+import Control.DeepSeq (NFData)  import Data.Text.Glyphize.Oom (throwFalse, throwNull)+import Data.Text.Glyphize.Array (iterateLazy, noCache)  import qualified Data.Text.Array as A import GHC.Exts (ByteArray#, sizeofByteArray#, Int#)@@ -17,7 +19,9 @@ import Data.Bits ((.|.), (.&.), shiftR, shiftL, testBit)  import System.IO.Unsafe (unsafePerformIO)+ import Foreign.Marshal.Alloc (alloca, allocaBytes)+import Foreign.Marshal.Array (peekArray) import Foreign.Ptr import Foreign.C.String (CString, withCString, peekCString) import Foreign.Storable (Storable(..))@@ -389,40 +393,23 @@     -- 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.'+} deriving (Show, Read, Eq, Generic)+instance NFData GlyphInfo+-- | Decodes multiple `GlyphInfo`s from a dereferenced `Word32` list according to+-- Harfbuzz's ABI.+decodeInfos :: [Word32] -> [GlyphInfo]+decodeInfos (codepoint':cluster':mask:_:_:rest) =+    GlyphInfo codepoint' cluster' (mask `testBit` 1) (mask `testBit` 2)+        (mask `testBit` 3):decodeInfos rest+decodeInfos _ = []+-- | Decodes `Buffer'`'s glyph information array. glyphInfos buf' = do     arr <- throwNull $ 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+    words <- iterateLazy arr (fromEnum length * 5)+    return $ noCache decodeInfos words foreign import ccall "hb_buffer_get_glyph_infos" hb_buffer_get_glyph_infos-    :: Buffer' -> Ptr Word -> IO (Ptr GlyphInfo)+    :: Buffer' -> Ptr Word -> IO (Ptr Word32) 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. @@ -442,33 +429,21 @@     -- ^ 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.+instance NFData GlyphPos+-- | Decode multiple `GlyphPos`s from a dereferenced list according to+-- Harfbuzz's ABI.+decodePositions (x_advance':y_advance':x_offset':y_offset':_:rest) =+    GlyphPos x_advance' y_advance' x_offset' y_offset':decodePositions rest+decodePositions _ = [] -- | Decodes `Buffer'`'s glyph position array. -- If buffer did not have positions before, they will be initialized to zeros.' glyphsPos buf' = do     arr <- throwNull $ 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+    words <- iterateLazy arr (fromEnum length * 5)+    return $ noCache decodePositions words foreign import ccall "hb_buffer_get_glyph_positions" hb_buffer_get_glyph_positions-    :: Buffer' -> Ptr Word -> IO (Ptr GlyphPos)+    :: Buffer' -> Ptr Word -> IO (Ptr Int32) -- NOTE: The array returned from FFI is valid as long as the buffer is.  -- | Decodes a `Buffer'` back to corresponding pure-functional `Buffer`.
Data/Text/Glyphize/Font.hs view
@@ -11,13 +11,14 @@ import Data.Text.Glyphize.Oom (throwNull, throwFalse)  import Control.Monad (forM, unless)+import Control.Exception (bracket) import Data.Maybe (fromMaybe) -import System.IO.Unsafe (unsafePerformIO)+import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) 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.Marshal.Array (withArray, withArrayLen, peekArray) import Foreign.Storable (Storable(..)) import Foreign.Storable.Generic (GStorable(..)) import GHC.Generics (Generic(..))@@ -121,9 +122,7 @@  -- | Fetches the number of `Face`s in a `ByteString`. countFace :: ByteString -> Word-countFace bytes = unsafePerformIO $ do-    blob <- bs2blob bytes-    withForeignPtr blob hb_face_count+countFace bytes = unsafePerformIO $ withBlob bytes hb_face_count foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Word  -- | A Font face.@@ -140,8 +139,7 @@ -- load named-instances in variable fonts. See `createFont` for details. createFace :: ByteString -> Word -> Face createFace bytes index = unsafePerformIO $ do-    blob <- bs2blob bytes-    face <- withForeignPtr blob $ throwNull . flip hb_face_create index+    face <- withBlob bytes $ throwNull . flip hb_face_create index     hb_face_make_immutable face     newForeignPtr hb_face_destroy face foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Word -> IO Face_@@ -260,8 +258,7 @@ -- | Variant of `createFace` which applies given options. createFaceWithOpts  :: FaceOptions -> ByteString -> Word -> Face createFaceWithOpts opts bytes index = unsafePerformIO $ do-    blob <- bs2blob bytes-    face <- withForeignPtr blob $ throwNull . flip hb_face_create index+    face <- withBlob bytes $ throwNull . flip hb_face_create index     _setFaceOptions face opts     hb_face_make_immutable face     newForeignPtr hb_face_destroy face@@ -279,9 +276,8 @@ buildFace :: [(String, ByteString)] -> FaceOptions -> Face buildFace tables opts = unsafePerformIO $ do     builder <- throwNull hb_face_builder_create-    forM tables $ \(tag, bytes) -> do-        blob <- bs2blob bytes-        throwFalse $ withForeignPtr blob $+    forM tables $ \(tag, bytes) ->+        throwFalse $ withBlob bytes $             hb_face_builder_add_table builder $ tag_from_string tag     _setFaceOptions builder opts     hb_face_make_immutable builder@@ -367,11 +363,11 @@ -- with an optional variation selector. fontGlyph :: Font -> Char -> Maybe Char -> Maybe Word32 fontGlyph font char var =-    unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do+    unsafeDupablePerformIO $ 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 fontGlyph' font char var =-    unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do+    unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do         throwFalse $ hb_font_get_glyph font' (c2w char) (c2w $ fromMaybe '\0' var) ret         peek ret foreign import ccall "hb_font_get_glyph" hb_font_get_glyph@@ -382,7 +378,7 @@ -- 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 $+fontGlyphAdvance font glyph dir = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do         hb_font_get_glyph_advance_for_direction font' glyph (dir2int dir) x' y'         x <- peek x'@@ -395,7 +391,7 @@ -- | 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 $+fontGlyphContourPoint font glyph index = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do         success <- hb_font_get_glyph_contour_point font' glyph index x' y'         if success@@ -404,7 +400,7 @@             y <- peek y'             return $ Just (x, y)         else return Nothing-fontGlyphContourPoint' font glyph index = unsafePerformIO $+fontGlyphContourPoint' font glyph index = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do         throwFalse $ hb_font_get_glyph_contour_point font' glyph index x' y'         x <- peek x'@@ -419,7 +415,7 @@ -- 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 $+fontGlyphContourPointForOrigin font glyph index dir = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do         success <- hb_font_get_glyph_contour_point_for_origin font' glyph index                 (dir2int dir) x' y'@@ -429,7 +425,7 @@             y <- peek y'             return $ Just (x, y)         else return Nothing-fontGlyphContourPointForOrigin' font glyph index dir = unsafePerformIO $+fontGlyphContourPointForOrigin' font glyph index dir = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do         throwFalse $ hb_font_get_glyph_contour_point_for_origin font' glyph index                 (dir2int dir) x' y'@@ -455,13 +451,13 @@ instance GStorable GlyphExtents -- | Fetches the `GlyphExtents` data for a glyph ID in the specified `Font`. fontGlyphExtents :: Font -> Word32 -> Maybe GlyphExtents-fontGlyphExtents font glyph = unsafePerformIO $+fontGlyphExtents font glyph = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         success <- hb_font_get_glyph_extents font' glyph ret         if success         then return . Just =<< peek ret         else return Nothing-fontGlyphExtents' font glyph = unsafePerformIO $+fontGlyphExtents' font glyph = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         throwFalse $ hb_font_get_glyph_extents font' glyph ret         peek ret@@ -473,13 +469,13 @@ -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of given `Direction`. fontGlyphExtentsForOrigin :: Font -> Word32 -> Maybe Direction -> Maybe GlyphExtents-fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $+fontGlyphExtentsForOrigin font glyph dir = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         ok <- hb_font_get_glyph_extents_for_origin font' glyph (dir2int dir) ret         if ok         then return . Just =<< peek ret         else return Nothing-fontGlyphExtentsForOrigin' font glyph dir = unsafePerformIO $+fontGlyphExtentsForOrigin' font glyph dir = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         throwFalse $ hb_font_get_glyph_extents_for_origin font' glyph (dir2int dir) ret         peek ret@@ -489,14 +485,14 @@  -- | Fetches the glyph ID that corresponds to a name string in the specified `Font`. fontGlyphFromName :: Font -> String -> Maybe Word32-fontGlyphFromName font name = unsafePerformIO $+fontGlyphFromName font name = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         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-fontGlyphFromName' font name = unsafePerformIO $+fontGlyphFromName' font name = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         throwFalse $ withCStringLen name $ \(name', len) ->             hb_font_get_glyph_from_name font' name' len ret@@ -528,7 +524,7 @@ -- | 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' ->+fontGlyphHOrigin font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' ->     alloca $ \x' -> alloca $ \y' -> do         success <- hb_font_get_glyph_h_origin font' glyph x' y'         if success@@ -537,7 +533,7 @@             y <- peek y'             return $ Just (x, y)         else return Nothing-fontGlyphHOrigin' font glyph = unsafePerformIO $ withForeignPtr font $ \font' ->+fontGlyphHOrigin' font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' ->     alloca $ \x' -> alloca $ \y' -> do         throwFalse $ hb_font_get_glyph_h_origin font' glyph x' y'         x <- peek x'@@ -549,7 +545,7 @@ -- | 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' ->+fontGlyphVOrigin font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' ->     alloca $ \x' -> alloca $ \y' -> do         success <- hb_font_get_glyph_v_origin font' glyph x' y'         if success@@ -558,7 +554,7 @@             y <- peek y'             return $ Just (x, y)         else return Nothing-fontGlyphVOrigin' font glyph = unsafePerformIO $ withForeignPtr font $ \font' ->+fontGlyphVOrigin' font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' ->     alloca $ \x' -> alloca $ \y' -> do         throwFalse $ hb_font_get_glyph_v_origin font' glyph x' y'         x <- peek x'@@ -571,7 +567,7 @@ -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of given `Direction`. fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Int32, Int32)-fontGlyphKerningForDir font a b dir = unsafePerformIO $ withForeignPtr font $ \font' ->+fontGlyphKerningForDir font a b dir = unsafeDupablePerformIO $ 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'@@ -588,13 +584,13 @@ -- | 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' ->+fontGlyphName_ font glyph size = unsafeDupablePerformIO $ withForeignPtr font $ \font' ->     allocaBytes size $ \name' -> do         success <- hb_font_get_glyph_name font' glyph name' (toEnum size)         if success         then Just <$> peekCStringLen (name', size)         else return Nothing-fontGlyphName_' font glyph size = unsafePerformIO $ withForeignPtr font $ \font' ->+fontGlyphName_' font glyph size = unsafeDupablePerformIO $ withForeignPtr font $ \font' ->     allocaBytes size $ \name' -> do         throwFalse $ hb_font_get_glyph_name font' glyph name' (toEnum size)         peekCStringLen (name', size)@@ -605,7 +601,7 @@ -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of given `Direction`. fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Int32, Int32)-fontGlyphOriginForDir font glyph dir = unsafePerformIO $ withForeignPtr font $ \font' ->+fontGlyphOriginForDir font glyph dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' ->     alloca $ \x' -> alloca $ \y' -> do         hb_font_get_glyph_origin_for_direction font' glyph (dir2int dir) x' y'         x <- peek x'@@ -623,11 +619,11 @@ -- `fontVarGlyph` or use `fontGlyph`. fontNominalGlyph :: Font -> Char -> Maybe Word32 fontNominalGlyph font c =-    unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do+    unsafeDupablePerformIO $ 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 fontNominalGlyph' font c =-    unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do+    unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do         throwFalse $ hb_font_get_nominal_glyph font' (c2w c) glyph'         peek glyph' foreign import ccall "hb_font_get_nominal_glyph" hb_font_get_nominal_glyph ::@@ -636,13 +632,13 @@ -- | Fetches the parent of the given `Font`. fontParent :: Font -> Font fontParent child =-    unsafePerformIO (newForeignPtr_ =<< withForeignPtr child hb_font_get_parent)+    unsafeDupablePerformIO (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+    unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do         hb_font_get_ppem font' x' y'         x <- peek x'         y <- peek y'@@ -657,7 +653,7 @@  -- | Fetches the horizontal and vertical scale of a `Font`. fontScale :: Font -> (Int, Int)-fontScale font = unsafePerformIO $+fontScale font = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do         hb_font_get_scale font' x' y'         x <- peek x' :: IO Int32@@ -675,13 +671,13 @@ -- | 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 $+fontVarGlyph font unicode varSel = unsafeDupablePerformIO $     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-fontVarGlyph' font unicode varSel = unsafePerformIO $+fontVarGlyph' font unicode varSel = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \glyph' -> do         throwFalse $ hb_font_get_variation_glyph font' unicode varSel glyph'         peek glyph'@@ -693,11 +689,11 @@ -- 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 $+fontVarCoordsDesign font = unsafeDupablePerformIO $     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+        peekArray (fromEnum length) arr foreign import ccall "hb_font_get_var_coords_design"     hb_font_get_var_coords_design :: Font_ -> Ptr Word -> IO (Ptr Float) @@ -705,7 +701,7 @@ -- 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 $+fontVarCoordsNormalized font = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \length' -> do         arr <- throwNull $ hb_font_get_var_coords_normalized font' length'         length <- peek length'@@ -716,14 +712,14 @@ -- | 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 $+fontTxt2Glyph font str = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         ok <- withCStringLen str $ \(str', len) ->             hb_font_glyph_from_string font' str' len ret         if ok         then return . Just =<< peek ret         else return Nothing-fontTxt2Glyph' font str = unsafePerformIO $+fontTxt2Glyph' font str = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> alloca $ \ret -> do         throwFalse $ withCStringLen str $ \(str', len) ->             hb_font_glyph_from_string font' str' len ret@@ -735,7 +731,7 @@ -- 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 $+fontGlyph2Str font glyph length = unsafeDupablePerformIO $     withForeignPtr font $ \font' -> allocaBytes length $ \ret -> do         hb_font_glyph_to_string font' glyph ret length         peekCString ret@@ -760,7 +756,7 @@ -- 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+fontExtentsForDir font dir = unsafeDupablePerformIO $ alloca $ \ret -> do     withForeignPtr font $ \font' ->         hb_font_get_extents_for_direction font' (dir2int dir) ret     peek ret@@ -768,24 +764,24 @@     hb_font_get_extents_for_direction :: Font_ -> Int -> Ptr FontExtents -> IO ()  -- | Fetches the extents for a specified font, for horizontal text segments.-fontHExtents font = unsafePerformIO $ alloca $ \ret -> do+fontHExtents font = unsafeDupablePerformIO $ alloca $ \ret -> do     ok <- withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret     if ok     then return . Just =<< peek ret     else return Nothing-fontHExtents' font = unsafePerformIO $ alloca $ \ret -> do+fontHExtents' font = unsafeDupablePerformIO $ alloca $ \ret -> do     throwFalse $ withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret     peek ret 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+fontVExtents font = unsafeDupablePerformIO $ alloca $ \ret -> do     ok <- withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret     if ok     then return . Just =<< peek ret     else return Nothing-fontVExtents' font = unsafePerformIO $ alloca $ \ret -> do+fontVExtents' font = unsafeDupablePerformIO $ alloca $ \ret -> do     throwFalse $ withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret     peek ret foreign import ccall "hb_font_get_v_extents" hb_font_get_v_extents@@ -926,9 +922,18 @@     blob <- throwNull $ withForeignPtr bytes $ \bytes' ->         hb_blob_create bytes' len hb_MEMORY_MODE_DUPLICATE nullPtr nullFunPtr     newForeignPtr hb_blob_destroy blob+-- | Convert from a ByteString to a temporary copy of Harfbuzz's equivalent.+-- Do not use this Blob outside the passed callback.+withBlob :: ByteString -> (Blob_ -> IO a) -> IO a+withBlob (BS bytes len) cb = withForeignPtr bytes $ \bytes' -> do+    throwNull $ pure bytes'+    bracket+        (hb_blob_create bytes' len hb_MEMORY_MODE_READONLY nullPtr nullFunPtr)+        hb_blob_destroy' cb foreign import ccall "hb_blob_create" hb_blob_create ::     Ptr Word8 -> Int -> Int -> Ptr () -> FunPtr (Ptr () -> IO ()) -> IO Blob_ hb_MEMORY_MODE_DUPLICATE = 0+hb_MEMORY_MODE_READONLY = 1 foreign import ccall "&hb_blob_destroy" hb_blob_destroy :: FunPtr (Blob_ -> IO ())  -- | Convert to a ByteString from Harfbuzz's equivalent.@@ -944,11 +949,11 @@  -- | Internal utility for defining trivial language bindings unwrapping `Face` foreign pointers. faceFunc :: (Face_ -> a) -> (Face -> a)-faceFunc cb fce = unsafePerformIO $ withForeignPtr fce $ return . cb+faceFunc cb fce = unsafeDupablePerformIO $ 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+fontFunc cb fnt = unsafeDupablePerformIO $ withForeignPtr fnt $ return . cb  -- | Internal utility for exposing Harfbuzz functions that populate a bitset. -- Converts the populated bitset to a Haskell lazy linked-list.
Main.hs view
@@ -2,7 +2,7 @@ module Main where  import "harfbuzz-pure" Data.Text.Glyphize-import Control.Parallel.Strategies (parMap, rpar)+import Control.Parallel.Strategies (parMap, rdeepseq)  import Data.Text.Lazy (pack) import qualified Data.ByteString as BS@@ -21,4 +21,4 @@       let font = createFont $ createFace blob 0       case words of         "!":words' -> print $ shape font (defaultBuffer { text = pack $ unwords words' }) []-        _ -> print $ parMap rpar (shapeStr font) words+        _ -> print $ parMap rdeepseq (shapeStr font) words
+ bench/Main.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}+module Main where+import Criterion.Main+import Data.Text.Glyphize+import Data.FileEmbed+import System.FilePath ((</>))+import qualified Data.Text.Foreign as Txt+import qualified Data.Text.Lazy as Txt++import Control.Parallel.Strategies (parMap, rdeepseq)+import Data.Word (Word8)++-- Benchmarking these as well...+import Foreign.Marshal.Array (peekArray)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray)+import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO, unsafeInterleaveIO)+import Data.Text.Glyphize.Array++shapeStr txt = shape font defaultBuffer { text = txt } []+  where font = createFont $ createFace $(+                    makeRelativeToProject ("assets" </> "Lora-Regular.ttf") >>=+                    embedFile) 0++dracula = $(makeRelativeToProject ("bench" </> "dracula.txt") >>= embedStringFile)++main = defaultMain [+    bgroup "Dracula" [+        bench "Week-Head" $ whnf shapeStr dracula,+        bench "Normal Form" $ nf shapeStr dracula,+        bench "Paragraphs" $ nf (map shapeStr) $ Txt.lines dracula,+        bench "Words" $ nf (map shapeStr) $ Txt.words dracula,+        bench "Parallelised" $ nf (parMap rdeepseq shapeStr) $ Txt.lines dracula,+        bench "Parallelised words" $ nf (parMap rdeepseq shapeStr) $+            Txt.words dracula+    ],+    bench "Word" $ nf shapeStr "Dracula",+    bgroup "building blocks" [+        bench "peekArray (NF)" $ nfIO $ Txt.useAsPtr (Txt.toStrict dracula) $+            \ptr l -> peekArray (fromEnum l) ptr,+        bench "peekArray" $ whnfIO $ Txt.useAsPtr (Txt.toStrict dracula) $+            \ptr l -> peekArray (fromEnum l) ptr,+        bench "alloc foreign ptr" $ whnfIO (mallocForeignPtrArray $+            fromEnum $ Txt.length dracula :: IO (ForeignPtr Word8)),+        bench "clone ptr" $ whnfIO $ Txt.useAsPtr (Txt.toStrict dracula) $+            \ptr l -> clonePtr ptr $ fromEnum l,+        bench "peek lazy" $ whnfIO (Txt.asForeignPtr (Txt.toStrict dracula) >>=+            \(ptr, l) -> return $ peekLazy ptr $ fromEnum l),+        bench "iterate lazy" $ whnfIO $ Txt.useAsPtr (Txt.toStrict dracula) $+            \ptr l -> iterateLazy ptr $ fromEnum l,+        bench "peek lazy (NF)" $ nfIO $ (Txt.asForeignPtr (Txt.toStrict dracula) >>=+            \(ptr, l) -> return $ peekLazy ptr $ fromEnum l),+        bench "iterate lazy (NF)" $ nfIO $ Txt.useAsPtr (Txt.toStrict dracula) $+            \ptr l -> iterateLazy ptr $ fromEnum l,+        -- These benchmarks give unconfident results, thought they'd be interesting...+        bench "unsafePerformIO" $ whnf unsafePerformIO $ return (),+        bench "unsafeDupablePerformIO" $ whnf unsafeDupablePerformIO $ return (),+        bench "unsafeInterleaveIO" $ whnfIO $ unsafeInterleaveIO $ return (),+        bench "accursedUnutterablePerformIO" $ whnf accursedUnutterablePerformIO $ return (),+        bench "peek kilo array" $ nfIO $ Txt.useAsPtr (Txt.toStrict $ Txt.take 1024 dracula) $+            \ptr l -> peekArray (fromEnum l) ptr,+        bench "lazy kilo array" $ nfIO (Txt.asForeignPtr (Txt.toStrict $ Txt.take 1024 dracula) >>=+                \(ptr, l) -> return $ peekLazy ptr $ fromEnum l)+    ]+  ]
harfbuzz-pure.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.0.3.2+version:             1.0.4.0  -- A short (one-line) description of the package. synopsis:            Pure-functional Harfbuzz language bindings@@ -57,16 +57,16 @@  library   -- Modules exported by the library.-  exposed-modules:     Data.Text.Glyphize+  exposed-modules:     Data.Text.Glyphize, Data.Text.Glyphize.Array      -- Modules included in this library but not exported.-  other-modules:       Data.Text.Glyphize.Buffer, Data.Text.Glyphize.Font, Data.Text.Glyphize.Oom+  other-modules:       Data.Text.Glyphize.Font, Data.Text.Glyphize.Buffer, Data.Text.Glyphize.Oom      -- LANGUAGE extensions used by modules in this package.   -- other-extensions:          -- Other library packages from which modules are imported.-  build-depends:       base >=4.12 && <5, text >= 2.0 && < 3,+  build-depends:       base >=4.12 && <5, text >= 2.0 && < 3, deepseq >= 1,                        bytestring >= 0.11, freetype2 >= 0.2, derive-storable >= 0.3 && < 1   pkgconfig-depends:   harfbuzz >= 3.3   @@ -88,5 +88,24 @@    -- Base language which the package is written in.   default-language:    Haskell2010++  ghc-options: -threaded++executable benchmark-harfbuzz+  hs-source-dirs:   bench+  main-is:          Main.hs+  build-depends:    base, harfbuzz-pure, file-embed > 0.15 && < 1,+        criterion >= 1 && < 2, filepath, text, parallel+  default-language: Haskell2010++  ghc-options: -threaded++benchmark bench-harfbuzz+  type:             exitcode-stdio-1.0+  hs-source-dirs:   bench+  main-is:          Main.hs+  build-depends:    base, harfbuzz-pure, file-embed > 0.15 && < 1,+        criterion >= 1 && < 2, filepath, text, parallel+  default-language: Haskell2010    ghc-options: -threaded