diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,23 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.2.1.0 - 2026-08-15 + +Added: +- `KB.Text.Shape.Segmentation` higher-level wrapper. +- `ttf2kbts` mini-app to extract kbts blobs. + +Fixed in upstream with local patches: +- `kbts_BreakEntireString*` no longer leaves unwritten holes in the output + array or over-reports `*BreakCount` when breaks merge into a written position. +- Breaks flushed after look-ahead now use the fed position increments, so + byte positions from `kbts_BreakEntireStringUtf8` are exact around + multi-byte codepoints and combining marks. +- `kbts_ShapePopFeature` reports the removal and no longer corrupts the + feature stack when popping a non-topmost override. +- `Font.getFontInfo` decodes name strings leniently, so fonts with non-UTF-8 + name records (e.g. Mac Roman) load instead of failing. + ## 0.2.0.0 - 2026-07-28 Updated `kb_text_shape` to 2.24. diff --git a/app/ttf2kbts/Main.hs b/app/ttf2kbts/Main.hs new file mode 100644 --- /dev/null +++ b/app/ttf2kbts/Main.hs @@ -0,0 +1,53 @@ +module Main (main) where + +import Data.ByteString qualified as ByteString +import Options.Applicative +import System.FilePath (replaceExtension) + +import KB.Text.Shape.Font qualified as Font + +main :: IO () +main = do + Options{..} <- execParser optionsInfo + ttfData <- ByteString.readFile inputPath + blobData <- Font.extractBlob ttfData fontIndex + ByteString.writeFile (resolveOutput inputPath outputPath) blobData + +data Options = Options + { inputPath :: FilePath + , outputPath :: Maybe FilePath + , fontIndex :: Int + } + +resolveOutput :: FilePath -> Maybe FilePath -> FilePath +resolveOutput inputPath = \case + Just explicit -> explicit + Nothing -> replaceExtension inputPath "kbts" + +optionsInfo :: ParserInfo Options +optionsInfo = info (helper <*> optionsParser) $ mconcat + [ fullDesc + , progDesc "Extract a pre-processed .kbts blob from a font file" + ] + +optionsParser :: Parser Options +optionsParser = do + inputPath <- strArgument $ mconcat + [ metavar "FONT" + , help "Input font file (TTF/OTF)" + ] + outputPath <- optional . strOption $ mconcat + [ long "output" + , short 'o' + , metavar "FILE" + , help "Output .kbts file (default: FONT with the extension replaced by .kbts)" + ] + fontIndex <- option auto $ mconcat + [ long "index" + , short 'i' + , metavar "N" + , value 0 + , showDefault + , help "Font index inside a collection" + ] + pure Options{..} diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -5,7 +5,7 @@ import Prelude hiding (id) import Control.Exception (bracket) -import Control.Monad (foldM, when) +import Control.Monad (when) import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString import Data.ByteString.Unsafe qualified as ByteString @@ -22,6 +22,7 @@ import KB.Text.Shape qualified as TextShape import KB.Text.Shape.Font qualified as Font +import KB.Text.Shape.Segmentation qualified as TextSegmentation main :: IO () main = do @@ -52,13 +53,13 @@ , bench "long text" $ whnfIO $ shapeVia ctx longText ] , bgroup "direct shaping" - [ bench "cold oneshot" $ whnfIO $ oneshot font testCodepoints + [ bench "cold oneshot" $ whnfIO $ oneshot font testText , bcompare "$NF == \"cold oneshot\"" $ - bench "warm scratchpad" $ whnfIO $ warmShot font scratchpad testCodepoints + bench "warm scratchpad" $ whnfIO $ warmShot font scratchpad testText ] , bgroup "segmentation" [ bench "BreakEntireStringUtf8" $ whnfIO $ breakUtf8 longUtf8 - , bench "incremental breaks" $ whnfIO $ breakIncremental longString + , bench "Segmentation.breaks" $ whnf (length . TextSegmentation.breaks) longText ] , bgroup "glyph mapping" [ bench "kbts_CodepointToGlyphId" $ whnfIO $ @@ -75,15 +76,9 @@ testText :: Text testText = "Hello, ሰላም።, שלמלך, नमस्ते world!" -testCodepoints :: [Char] -testCodepoints = Text.unpack testText - longText :: Text longText = Text.replicate 64 testText -longString :: [Char] -longString = Text.unpack longText - longUtf8 :: ByteString longUtf8 = Text.encodeUtf8 longText @@ -92,21 +87,21 @@ shapeVia ctx text = length . show <$> TextShape.run ctx (TextShape.text_ text) -- | Direct shaping with the full per-call setup: config, scratchpad, storage. -oneshot :: Handles.Font -> [Char] -> IO Int -oneshot font codepoints = +oneshot :: Handles.Font -> Text -> IO Int +oneshot font text = withShapeConfig font \config -> withScratchpad config \scratchpad -> -- Glyphs keep the config pointer, it has to outlive the shaping. withGlyphConfig config \glyphConfig -> withGlyphStorage \storagePtr -> do - pushCodepoints font storagePtr glyphConfig codepoints + pushCodepoints font storagePtr glyphConfig (Text.unpack text) drainShape scratchpad storagePtr -- | Direct shaping reusing a pre-built config and scratchpad. -warmShot :: Handles.Font -> Handles.ShapeScratchpad -> [Char] -> IO Int -warmShot font scratchpad codepoints = +warmShot :: Handles.Font -> Handles.ShapeScratchpad -> Text -> IO Int +warmShot font scratchpad text = withGlyphStorage \storagePtr -> do - pushCodepoints font storagePtr (Handles.GlyphConfig nullPtr) codepoints + pushCodepoints font storagePtr (Handles.GlyphConfig nullPtr) (Text.unpack text) drainShape scratchpad storagePtr drainShape :: Handles.ShapeScratchpad -> Ptr Structs.GlyphStorage -> IO Int @@ -139,21 +134,6 @@ (fromIntegral len) flagCountPtr fromIntegral <$> peek breakCountPtr - -breakIncremental :: [Char] -> IO Int -breakIncremental text = - allocaBytes Handles.sizeOfBreakState \raw -> do - fillBytes raw 0 Handles.sizeOfBreakState - let state = Handles.BreakState (castPtr raw) - Segmentation.kbts_BreakBegin state Enums.DIRECTION_DONT_KNOW Enums.JAPANESE_LINE_BREAK_STYLE_NORMAL mempty - alloca \breakPtr -> do - let drain !n = do - more <- Segmentation.kbts_Break state breakPtr - if more /= 0 then drain (n + 1) else pure n - feed !n (c, isLast) = do - Segmentation.kbts_BreakAddCodepoint state (fromIntegral (ord c)) 1 (if isLast then 1 else 0) - drain n - foldM feed (0 :: Int) $ zip text (replicate (length text - 1) False <> [True]) -- * Fixtures diff --git a/cbits/kb_text_shape.inc b/cbits/kb_text_shape.inc --- a/cbits/kb_text_shape.inc +++ b/cbits/kb_text_shape.inc @@ -20819,12 +20819,15 @@ if(Override->Tag == Tag) { + // LOCAL PATCH(pop_feature_returns_zero): shift with MoveIndex (the loop used to + // copy one slot onto itself, corrupting non-topmost pops) and report the removal. KBTS__FOR(MoveIndex, ScratchFeatureOverrideIndex, Context->ScratchFeatureOverrideCount) { - Context->ScratchFeatureOverrides[ScratchFeatureOverrideIndex - 1] = Context->ScratchFeatureOverrides[ScratchFeatureOverrideIndex]; + Context->ScratchFeatureOverrides[MoveIndex - 1] = Context->ScratchFeatureOverrides[MoveIndex]; } Context->ScratchFeatureOverrideCount -= 1; + Result = 1; break; } } @@ -23894,10 +23897,14 @@ { kbts_u64 EffectiveLineBreaks = LineBreaks & ~(LineUnbreaks | LineUnbreaksAsync); - kbts__DoLineBreak(State, PositionOffset3 + LineBreak3PositionOffset, EffectiveLineBreaks >> 48); + // LOCAL PATCH(break_position_skew): LineBreak2/3PositionOffset are now full offsets + // from CurrentPosition (like ScriptPositionOffset), accumulating the actual + // PositionIncrements across absorbed characters instead of being added to + // PositionOffset2/3, which only track the last two fed codepoints. + kbts__DoLineBreak(State, LineBreak3PositionOffset, EffectiveLineBreaks >> 48); if(EndOfText) { - kbts__DoLineBreak(State, PositionOffset2 + LineBreak2PositionOffset, EffectiveLineBreaks >> 32); + kbts__DoLineBreak(State, LineBreak2PositionOffset, EffectiveLineBreaks >> 32); { // @Cleanup: This is the same flag code as DoLineBreak, but we want to use FlagState buffering for this. // The only places where we want to manually call DoBreak is for asynchronous/buffered guys. kbts_u8 FlushedLineFlags = 0; @@ -23912,8 +23919,9 @@ State->LineBreaks = LineBreaks; State->LineUnbreaks = LineUnbreaks; - State->LineBreak2PositionOffset = 0; - State->LineBreak3PositionOffset = LineBreak2PositionOffset; + // LOCAL PATCH(break_position_skew): keep full offsets in step with the fed increments. + State->LineBreak2PositionOffset = (kbts_s16)-(int)PositionIncrement; + State->LineBreak3PositionOffset = (kbts_s16)(LineBreak2PositionOffset - (int)PositionIncrement); State->LastLineBreakClass = LineBreakClass; State->LineBreakHistory = LineBreakHistory; @@ -24231,7 +24239,9 @@ KBTS_C2(WSS, WSS): // WSS x WSS is a special rule, because it is supposed to happen _before_ ignores. - if(WordBreak2PositionOffset >= 0) WordUnbreaks |= KBTS_WORD_BREAK_BITS(0, 1); + // LOCAL PATCH(break_position_skew): "no ignores since the last word step" is now + // "the full offset still equals the last fed increment". + if(WordBreak2PositionOffset == PositionOffset2) WordUnbreaks |= KBTS_WORD_BREAK_BITS(0, 1); break; // (RI RI)* RI x RI @@ -24267,7 +24277,8 @@ kbts_u32 EffectiveWordBreaks = WordBreaks & ~WordUnbreaks; if(EffectiveWordBreaks & KBTS_WORD_BREAK_BITS(2, 2)) { - kbts__DoBreak(State, PositionOffset2 + WordBreak2PositionOffset, KBTS_BREAK_FLAG_WORD, 0, 0, 0); + // LOCAL PATCH(break_position_skew): WordBreak2PositionOffset is a full offset now. + kbts__DoBreak(State, WordBreak2PositionOffset, KBTS_BREAK_FLAG_WORD, 0, 0, 0); } if(EndOfText) { @@ -24279,7 +24290,8 @@ State->WordBreaks = (kbts_u16)WordBreaks; State->WordUnbreaks = (kbts_u16)WordUnbreaks; State->LastWordBreakClass = WordBreakClass; - State->WordBreak2PositionOffset = 0; + // LOCAL PATCH(break_position_skew): keep the full offset in step with the fed increment. + State->WordBreak2PositionOffset = (kbts_s16)-(int)PositionIncrement; State->WordBreakHistory = WordBreakHistory; } State->LastWordBreakClassIncludingIgnored = WordBreakClass; @@ -24568,9 +24580,14 @@ kbts_break Break; while(kbts_Break(&BreakState, &Break)) { + // LOCAL PATCH(break_entire_string_holes): only advance the write cursor when a + // record was actually written; merged breaks used to leave unwritten holes and + // over-report *BreakCount. With a null Breaks, Found stays 0 and the count keeps + // its old upper-bound semantics for two-pass sizing. + int Found = 0; + if(Breaks && (BreaksWritten < BreakCapacity)) { - int Found = 0; kbts_un ExistingBreakCount = KBTS__MIN(BreaksWritten, BreakCapacity); // @Speed: Binary search! @@ -24613,7 +24630,10 @@ MaxBreakPosition = KBTS__MAX(MaxBreakPosition, (kbts_u32)Break.Position); - BreaksWritten += 1; + if(!Found) + { + BreaksWritten += 1; + } } } diff --git a/kb-text-shape.cabal b/kb-text-shape.cabal --- a/kb-text-shape.cabal +++ b/kb-text-shape.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: kb-text-shape -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Unicode segmentation and shaping using kb_text_shape category: Font homepage: https://github.com/dpwiz/kb-text-shape#readme @@ -49,6 +49,7 @@ KB.Text.Shape.FFI.Iterators KB.Text.Shape.FFI.Structs KB.Text.Shape.Font + KB.Text.Shape.Segmentation other-modules: Paths_kb_text_shape autogen-modules: @@ -65,7 +66,6 @@ LambdaCase NamedFieldPuns NoFieldSelectors - NoFieldSelectors OverloadedRecordDot OverloadedStrings PatternSynonyms @@ -87,6 +87,40 @@ if flag(trace-blocks) cc-options: -DTRACE_BLOCKS +executable ttf2kbts + main-is: Main.hs + other-modules: + Paths_kb_text_shape + autogen-modules: + Paths_kb_text_shape + hs-source-dirs: + app/ttf2kbts + default-extensions: + BlockArguments + DataKinds + DerivingStrategies + DuplicateRecordFields + GeneralizedNewtypeDeriving + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RecordWildCards + StrictData + ViewPatterns + ApplicativeDo + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , bytestring + , filepath + , kb-text-shape + , optparse-applicative + default-language: GHC2021 + test-suite kb-text-shape-test type: exitcode-stdio-1.0 main-is: Spec.hs @@ -106,7 +140,6 @@ LambdaCase NamedFieldPuns NoFieldSelectors - NoFieldSelectors OverloadedRecordDot OverloadedStrings PatternSynonyms @@ -142,7 +175,6 @@ ImplicitParams LambdaCase NamedFieldPuns - NoFieldSelectors NoFieldSelectors OverloadedRecordDot OverloadedStrings diff --git a/src/KB/Text/Shape.hs b/src/KB/Text/Shape.hs --- a/src/KB/Text/Shape.hs +++ b/src/KB/Text/Shape.hs @@ -51,6 +51,7 @@ import GHC.Records (HasField(..)) import KB.Text.Shape.FFI.API.Context qualified as ShapeContext +import KB.Text.Shape.Font qualified as Font import KB.Text.Shape.FFI.Enums qualified as Enums import KB.Text.Shape.FFI.Flags qualified as Flags import KB.Text.Shape.FFI.Handles qualified as Handles @@ -102,6 +103,25 @@ when (err /= Enums.SHAPE_ERROR_NONE) $ error $ "kbts_ShapePushFontFromFile: failed to load font. " <> show err _ <- keepFont ctx font mempty -- register the empty blob so the counters would look nicer + validateFont ("kbts_ShapePushFontFromFile: " <> path) font + +{- | Reject fonts that failed to load or whose metrics would poison layout downstream. + +The loader hands back a null handle without setting the shape error when the +file is missing, unreadable, or not a font. +A zero 'KB.Text.Shape.Font.Info.unitsPerEm' means the font did not parse; +a missing capital height (OS/2 @sCapHeight@) breaks cap-normalized sizing +with no sensible fallback. +-} +validateFont :: String -> Handles.Font -> IO Handles.Font +validateFont origin font = do + when (font == Handles.Font nullPtr) $ + error $ origin <> ": failed to load font" + info <- Font.getFontInfo font + when (info.unitsPerEm == 0) $ + error $ origin <> ": font reports zero unitsPerEm" + when (info.capitalHeight <= 0) $ + error $ origin <> ": font has no capital height (OS/2 sCapHeight)" pure font pushFontFromMemory :: Context -> ByteString -> Int -> IO Handles.Font @@ -112,7 +132,7 @@ when (err /= Enums.SHAPE_ERROR_NONE) $ error $ "kbts_ShapePushFontFromMemory: failed to load font. " <> show err _ <- keepFont ctx font fontData - pure font + validateFont "kbts_ShapePushFontFromMemory" font keepFont :: Context -> Handles.Font -> ByteString -> IO Int keepFont ctx font bytes = atomicModifyIORef' ctx.fonts $ swap . IntMap.alterF addRef (Handles.intHandle font) @@ -277,6 +297,11 @@ , uid :: Word16 , codepointIndex :: Int -- was: userIdOrCodepointIndex + {- ^ Index of the source codepoint this glyph maps to, in codepoints, + relative to the whole shaped input (not the run). Several glyphs may + share an index (marks), and a ligature carries the index of its first + codepoint, leaving the rest without glyphs. + -} , offsetX :: Int {- ^ This, and the next few are in the "font units". diff --git a/src/KB/Text/Shape/Font.hs b/src/KB/Text/Shape/Font.hs --- a/src/KB/Text/Shape/Font.hs +++ b/src/KB/Text/Shape/Font.hs @@ -32,7 +32,8 @@ import Data.ByteString.Unsafe qualified as ByteString import Data.Maybe (catMaybes) import Data.Text (Text) -import Data.Text.Foreign qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Text.Encoding.Error (lenientDecode) import KB.Text.Shape.FFI.API.Direct qualified as ShapeDirect import KB.Text.Shape.FFI.Flags qualified as Flags @@ -92,7 +93,7 @@ where loadStrings (ix, ptr) = \case 0 -> pure Nothing - len -> Just . (Enums.FontInfoStringId ix,) <$> Text.peekCStringLen (ptr, fromIntegral len) + len -> Just . (Enums.FontInfoStringId ix,) . Text.decodeUtf8With lenientDecode <$> ByteString.unsafePackCStringLen (ptr, fromIntegral len) data Info = Info { strings :: [(Enums.FontInfoStringId, Text)] diff --git a/src/KB/Text/Shape/Segmentation.hs b/src/KB/Text/Shape/Segmentation.hs new file mode 100644 --- /dev/null +++ b/src/KB/Text/Shape/Segmentation.hs @@ -0,0 +1,145 @@ +{-| Unicode segmentation over the kbts entire-string API. + +All positions are UTF-8 byte offsets into the input 'Text'. +-} +module KB.Text.Shape.Segmentation + ( Break (..) + , breaks + , breaksWith + + -- * Grapheme clusters + , clusters + , boundaries + + -- * Line break opportunities + , softBreaks + , softBreaksWith + + -- * Word boundaries + , wordBreaks + ) where + +import Data.Bits ((.&.)) +import Data.Char (ord) +import Data.IntSet qualified as IntSet +import Data.List (sort) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Foreign qualified as Text +import Foreign (alloca, allocaArray, fillBytes, nullPtr, peek, peekArray, sizeOf) +import System.IO.Unsafe (unsafePerformIO) + +import KB.Text.Shape.FFI.API.Segmentation qualified as Segmentation +import KB.Text.Shape.FFI.Enums (JapaneseLineBreakStyle, pattern DIRECTION_DONT_KNOW, pattern JAPANESE_LINE_BREAK_STYLE_NORMAL) +import KB.Text.Shape.FFI.Flags (BreakFlags, pattern BREAK_FLAG_GRAPHEME, pattern BREAK_FLAG_LINE_SOFT, pattern BREAK_FLAG_WORD) +import KB.Text.Shape.FFI.Structs (Break (..)) + +{- | Extended grapheme cluster texts, in order. + +The engine skips UAX #29 GB11, so 'boundaries' refuses to cut adjacent +to a ZWJ; emoji ZWJ sequences stay whole. +-} +clusters :: Text -> [Text] +clusters t = go t 0 (boundaries t) + where + go rest from cuts = case dropWhile (<= from) cuts of + cut : more -> + let n = fromIntegral (cut - from) + in Text.takeWord8 n rest : go (Text.dropWord8 n rest) cut more + [] -> [rest | not (Text.null rest)] + +-- | Extended grapheme cluster boundaries. +boundaries :: Text -> [Int] +boundaries t = zwjFilter t (positions BREAK_FLAG_GRAPHEME (breaks t)) + +{- | Positions where a line may break, at 'JAPANESE_LINE_BREAK_STYLE_NORMAL'. + +The engine skips UAX #14 LB8a, so positions adjacent to a ZWJ are dropped. +-} +softBreaks :: Text -> [Int] +softBreaks = softBreaksWith JAPANESE_LINE_BREAK_STYLE_NORMAL + +-- | 'softBreaks' with an explicit kinsoku strictness. +softBreaksWith :: JapaneseLineBreakStyle -> Text -> [Int] +softBreaksWith style t = zwjFilter t (positions BREAK_FLAG_LINE_SOFT (breaksWith style t)) + +-- | UAX #29 word boundaries. +wordBreaks :: Text -> [Int] +wordBreaks = positions BREAK_FLAG_WORD . breaks + +positions :: BreakFlags -> [Break] -> [Int] +positions flag found = dedupe (sort [b.position | b <- found, b.flags .&. flag /= mempty]) + where + dedupe = \case + x : rest@(y : _) + | x == y -> dedupe rest + | otherwise -> x : dedupe rest + rest -> rest + +zwjFilter :: Text -> [Int] -> [Int] +zwjFilter t + | IntSet.null zwjs = id + | otherwise = filter safe + where + zwjs = IntSet.fromList (zwjOffsets 0 (Text.unpack t)) + zwjOffsets off = \case + [] -> [] + c : rest -> [off | c == '\x200D'] <> zwjOffsets (off + utf8Length c) rest + total = Text.lengthWord8 t + safe b = b <= 0 || b >= total || not (IntSet.member (b - 3) zwjs || IntSet.member b zwjs) + +utf8Length :: Char -> Int +utf8Length c + | o < 0x80 = 1 + | o < 0x800 = 2 + | o < 0x10000 = 3 + | otherwise = 4 + where + o = ord c + +-- | All breaks at 'JAPANESE_LINE_BREAK_STYLE_NORMAL'. +breaks :: Text -> [Break] +breaks = breaksWith JAPANESE_LINE_BREAK_STYLE_NORMAL + +{- | 'breaks' with an explicit kinsoku strictness, in one engine pass. + +The entire-string API merges the flags of same-position breaks into one +record; the 2.24 write-cursor caveat on +'Segmentation.kbts_BreakEntireString' is compensated by zeroing the output +buffer and dropping the records with empty flags. + +Delayed break emissions rely on the @LOCAL PATCH(break_position_skew)@ +in @cbits\/kb_text_shape.inc@: unpatched, positions of breaks pending on +lookahead skew away from the fed byte increments in both directions (see +@upstream-fixme\/break_position_skew.c@). +-} +breaksWith :: JapaneseLineBreakStyle -> Text -> [Break] +breaksWith style t + | Text.null t = [] + | otherwise = unsafePerformIO $ + Text.withCStringLen t \(utf8Ptr, len) -> + attempt utf8Ptr len (4 * len + 16) + where + attempt utf8Ptr len capacity = + allocaArray capacity \breaksPtr -> + alloca \breakCountPtr -> do + fillBytes breaksPtr 0 (capacity * sizeOf (undefined :: Break)) + Segmentation.kbts_BreakEntireStringUtf8 + DIRECTION_DONT_KNOW + style + mempty + utf8Ptr + (fromIntegral len) + breaksPtr + (fromIntegral capacity) + breakCountPtr + nullPtr + 0 + nullPtr + count <- fromIntegral <$> peek breakCountPtr + if count > capacity + then + attempt utf8Ptr len count + else + filter (\b -> b.flags /= mempty) <$> peekArray count breaksPtr +{-# NOINLINE breaksWith #-} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -33,6 +33,7 @@ import KB.Text.Shape qualified as TextShape import KB.Text.Shape.Font qualified as Font +import KB.Text.Shape.Segmentation qualified as TextSegmentation testFontTtf :: FilePath testFontTtf = "test/Ubuntu-R.ttf" @@ -265,7 +266,7 @@ TextShape.popFeature_ Enums.FEATURE_TAG_liga >>= writeIORef popped -- XXX: upstream kbts_ShapePopFeature loses the found-and-removed -- result, it is always 0 as of 2.24. - readIORef popped >>= (@?= 0) + readIORef popped >>= (@?= 1) , testCase "shaped codepoints can be retrieved by index" $ withFontContext ttfData \ctx _font -> do @@ -357,7 +358,7 @@ alloca @Structs.GlyphStorage \storagePtr -> do ok <- ShapeDirect.kbts_InitializeGlyphStorageFixedMemory storagePtr (castPtr mem) (fromIntegral size) assertBool "storage initialized" (ok /= 0) - forM_ ("abc" :: String) \c -> do + forM_ (Text.unpack "abc") \c -> do glyphPtr <- ShapeDirect.kbts_PushGlyph storagePtr font (fromIntegral (ord c)) nullGlyphConfig 0 assertBool "glyph pushed" (glyphPtr /= nullPtr) glyphs <- shapeStorage scratchpad storagePtr @@ -402,7 +403,7 @@ , testCase "clearing active glyphs empties the iterator" $ withShapeSetup ttfData \font _config _scratchpad -> withGlyphStorage \storagePtr -> do - forM_ ("abc" :: String) \c -> + forM_ (Text.unpack "abc") \c -> void $ ShapeDirect.kbts_PushGlyph storagePtr font (fromIntegral (ord c)) nullGlyphConfig 0 alloca \itPtr -> do ShapeDirect.hs_ActiveGlyphIterator storagePtr itPtr @@ -457,6 +458,11 @@ -- real record, splitting the position across two records. mergeBreaks incremental @?= mergeBreaks whole + , testCase "Segmentation.breaks reports UTF-8 byte positions" $ do + let text = "øne two\nthree fõur" + whole <- breakEntireUtf8 text + mergeBreaks (TextSegmentation.breaks text) @?= mergeBreaks whole + , testCase "BreakEntireStringUtf8 agrees with UTF-32 on ASCII" $ do let text = "one two\nthree four" utf32 <- breakEntireUtf32 text @@ -495,13 +501,13 @@ coverage "汉字" >>= (@?= False) ] where - coverage :: String -> IO Bool + coverage :: Text -> IO Bool coverage text = withFont ttfData \font -> alloca @Structs.FontCoverageTest \testPtr -> do fillBytes testPtr 0 $ sizeOf (undefined :: Structs.FontCoverageTest) Other.kbts_FontCoverageTestBegin testPtr font - forM_ text \c -> + forM_ (Text.unpack text) \c -> Other.kbts_FontCoverageTestCodepoint testPtr (fromIntegral (ord c)) covered <- Other.kbts_FontCoverageTestEnd testPtr pure $ covered /= 0 @@ -599,10 +605,10 @@ [x] -> pure x other -> assertFailure $ "expected one run, got " <> show (length other) -directShape :: Handles.Font -> Handles.ShapeScratchpad -> Handles.GlyphConfig -> String -> IO [TextShape.Glyph] +directShape :: Handles.Font -> Handles.ShapeScratchpad -> Handles.GlyphConfig -> Text -> IO [TextShape.Glyph] directShape font scratchpad glyphConfig text = withGlyphStorage \storagePtr -> do - forM_ text \c -> + forM_ (Text.unpack text) \c -> ShapeDirect.kbts_PushGlyph storagePtr font (fromIntegral (ord c)) glyphConfig 0 shapeStorage scratchpad storagePtr @@ -622,9 +628,9 @@ Segmentation.kbts_GuessTextPropertiesUtf8 ptr (fromIntegral len) directionPtr scriptPtr (,) <$> peek directionPtr <*> peek scriptPtr -guessUtf32 :: String -> IO (Enums.Direction, Enums.Script) +guessUtf32 :: Text -> IO (Enums.Direction, Enums.Script) guessUtf32 text = - withArrayLen (map (fromIntegral . ord) text :: [CInt]) \len ptr -> + withArrayLen (map (fromIntegral . ord) (Text.unpack text) :: [CInt]) \len ptr -> alloca \directionPtr -> alloca \scriptPtr -> do poke directionPtr Enums.DIRECTION_DONT_KNOW poke scriptPtr Enums.SCRIPT_DONT_KNOW @@ -635,9 +641,9 @@ hasBreakFlag flags flag = flags .&. flag == flag -- | Collect breaks with 1-per-codepoint positions and a generous output capacity. -breakEntireUtf32 :: String -> IO [Structs.Break] +breakEntireUtf32 :: Text -> IO [Structs.Break] breakEntireUtf32 text = - withArrayLen (map (fromIntegral . ord) text :: [CInt]) \len codepointsPtr -> + withArrayLen (map (fromIntegral . ord) (Text.unpack text) :: [CInt]) \len codepointsPtr -> withBreakBuffers len \breaksPtr breakCountPtr flagsPtr flagCountPtr -> do Segmentation.kbts_BreakEntireStringUtf32 Enums.DIRECTION_DONT_KNOW @@ -652,9 +658,9 @@ (fromIntegral len) flagCountPtr -breakEntireUtf8 :: String -> IO [Structs.Break] +breakEntireUtf8 :: Text -> IO [Structs.Break] breakEntireUtf8 text = - Text.withCStringLen (Text.pack text) \(textPtr, len) -> + Text.withCStringLen text \(textPtr, len) -> withBreakBuffers len \breaksPtr breakCountPtr flagsPtr flagCountPtr -> do Segmentation.kbts_BreakEntireStringUtf8 Enums.DIRECTION_DONT_KNOW @@ -705,7 +711,7 @@ (before, (position, flags) : next) -> before <> ((position, flags <> b.flags) : next) (_, []) -> acc <> [(b.position, b.flags)] -breakIncremental :: String -> IO [Structs.Break] +breakIncremental :: Text -> IO [Structs.Break] breakIncremental text = allocaBytes Handles.sizeOfBreakState \raw -> do fillBytes raw 0 Handles.sizeOfBreakState @@ -722,11 +728,12 @@ feed acc (c, isLast) = do Segmentation.kbts_BreakAddCodepoint state (fromIntegral (ord c)) 1 (if isLast then 1 else 0) drain acc - annotated = zip text $ map (== length text) [1 ..] + codepoints = Text.unpack text + annotated = zip codepoints $ map (== length codepoints) [1 ..] reverse <$> foldM feed [] annotated -fourcc :: String -> Other.ScriptTag -fourcc = \case +fourcc :: Text -> Other.ScriptTag +fourcc tag = case Text.unpack tag of [a, b, c, d] -> Other.ScriptTag $ fromIntegral (ord a) .|. fromIntegral (ord b) `shiftL` 8