module KB.Text.Shape
  ( -- * The slow part
    withContext
  , Context(..)
  , createContext
  , destroyContext

    -- ** Adding fonts
    -- $stack
  , Handles.Font
  , pushFontFromFile
  , pushFontFromMemory
  , pushFont
  , popFont

    -- * Turning texts into glyphs
  , run
  , Run(..)
  , Glyph(..)
  , gpos
  , GPOS(..)
    -- ** Feeding input
  , text_
  , char_
    -- $features
  , withFeature_
  , pushFeature_
  , popFeature_
    -- * Internals
  , stripGlyph
  ) where

import Control.Monad
import Data.IORef
import Foreign
import Foreign.C
import Prelude hiding (id)

import Control.Exception (bracket)
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe qualified as ByteString
import Data.Char (chr, ord)
import Data.IntMap (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.Text (Text)
import Data.Text.Foreign qualified as Text
import GHC.Records (HasField(..))

import KB.Text.Shape.FFI.API.Context qualified as ShapeContext
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
import KB.Text.Shape.FFI.Iterators qualified as Iterators
import KB.Text.Shape.FFI.Structs qualified as Structs

withContext :: (Context -> IO r) -> IO r
withContext :: forall r. (Context -> IO r) -> IO r
withContext = IO Context -> (Context -> IO ()) -> (Context -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Context
createContext Context -> IO ()
destroyContext

data Context = Context
  { Context -> ShapeContext
handle :: Handles.ShapeContext
  , Context -> IORef (IntMap ByteStringRC)
fonts :: IORef (IntMap ByteStringRC)
  }

data ByteStringRC = ByteStringRC ByteString Int

createContext :: IO Context
createContext :: IO Context
createContext = do
  ShapeContext
handle <- FunPtr Allocator -> Ptr () -> IO ShapeContext
ShapeContext.kbts_CreateShapeContext FunPtr Allocator
forall a. FunPtr a
nullFunPtr Ptr ()
forall a. Ptr a
nullPtr
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShapeContext
handle ShapeContext -> ShapeContext -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ShapeContext -> ShapeContext
Handles.ShapeContext Ptr ShapeContext
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    -- XXX: assuming the default allocator didn't allocate anything yet
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"kbts_CreateShapeContext: failed to init"
  IORef (IntMap ByteStringRC)
fonts <- IntMap ByteStringRC -> IO (IORef (IntMap ByteStringRC))
forall a. a -> IO (IORef a)
newIORef IntMap ByteStringRC
forall a. Monoid a => a
mempty
  Context -> IO Context
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context{ShapeContext
handle :: ShapeContext
handle :: ShapeContext
handle, IORef (IntMap ByteStringRC)
fonts :: IORef (IntMap ByteStringRC)
fonts :: IORef (IntMap ByteStringRC)
fonts}

destroyContext :: Context -> IO ()
destroyContext :: Context -> IO ()
destroyContext Context{ShapeContext
handle :: Context -> ShapeContext
handle :: ShapeContext
handle} = ShapeContext -> IO ()
ShapeContext.kbts_DestroyShapeContext ShapeContext
handle

{- $stack

The context is capable of managing multiple fonts through a font stack.
The font stack will hold references to all fonts in use by the context. Whenever
you try to shape some text, the context will check to see if it is supported by
the font at the top of the stack. If it is not, it will try the next font down,
and so on, until all fonts have been tried. As such, you should push your fallback
fonts first, and your preferred fonts last.

-}

pushFontFromFile :: Context -> FilePath -> Int -> IO Handles.Font
pushFontFromFile :: Context -> [Char] -> Int -> IO Font
pushFontFromFile Context
ctx [Char]
path Int
fontIndex = do
  Font
font <- [Char] -> (CString -> IO Font) -> IO Font
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
path \CString
pathPtr ->
    ShapeContext -> CString -> CInt -> IO Font
ShapeContext.kbts_ShapePushFontFromFile Context
ctx.handle CString
pathPtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fontIndex)
  let err :: ShapeError
err = ShapeContext -> ShapeError
ShapeContext.kbts_ShapeError Context
ctx.handle
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShapeError
err ShapeError -> ShapeError -> Bool
forall a. Eq a => a -> a -> Bool
/= ShapeError
Enums.SHAPE_ERROR_NONE) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"kbts_ShapePushFontFromFile: failed to load font. " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ShapeError -> [Char]
forall a. Show a => a -> [Char]
show ShapeError
err
  Int
_ <- Context -> Font -> ByteString -> IO Int
keepFont Context
ctx Font
font ByteString
forall a. Monoid a => a
mempty -- register the empty blob so the counters would look nicer
  Font -> IO Font
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Font
font

pushFontFromMemory :: Context -> ByteString -> Int -> IO Handles.Font
pushFontFromMemory :: Context -> ByteString -> Int -> IO Font
pushFontFromMemory Context
ctx ByteString
fontData Int
fontIndex =
  ByteString -> (CStringLen -> IO Font) -> IO Font
forall a. ByteString -> (CStringLen -> IO a) -> IO a
ByteString.unsafeUseAsCStringLen ByteString
fontData \(CString
memoryPtr, Int
memorySize) -> do
    Font
font <- ShapeContext -> Ptr () -> CSize -> CInt -> IO Font
ShapeContext.kbts_ShapePushFontFromMemory Context
ctx.handle (CString -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr CString
memoryPtr) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
memorySize)  (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fontIndex)
    let err :: ShapeError
err = ShapeContext -> ShapeError
ShapeContext.kbts_ShapeError Context
ctx.handle
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShapeError
err ShapeError -> ShapeError -> Bool
forall a. Eq a => a -> a -> Bool
/= ShapeError
Enums.SHAPE_ERROR_NONE) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"kbts_ShapePushFontFromMemory: failed to load font. " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ShapeError -> [Char]
forall a. Show a => a -> [Char]
show ShapeError
err
    Int
_ <- Context -> Font -> ByteString -> IO Int
keepFont Context
ctx Font
font ByteString
fontData
    Font -> IO Font
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Font
font

keepFont :: Context -> Handles.Font -> ByteString -> IO Int
keepFont :: Context -> Font -> ByteString -> IO Int
keepFont Context
ctx Font
font ByteString
bytes = IORef (IntMap ByteStringRC)
-> (IntMap ByteStringRC -> (IntMap ByteStringRC, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' Context
ctx.fonts ((IntMap ByteStringRC -> (IntMap ByteStringRC, Int)) -> IO Int)
-> (IntMap ByteStringRC -> (IntMap ByteStringRC, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int, IntMap ByteStringRC) -> (IntMap ByteStringRC, Int)
forall {b} {a}. (b, a) -> (a, b)
swap ((Int, IntMap ByteStringRC) -> (IntMap ByteStringRC, Int))
-> (IntMap ByteStringRC -> (Int, IntMap ByteStringRC))
-> IntMap ByteStringRC
-> (IntMap ByteStringRC, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteStringRC -> (Int, Maybe ByteStringRC))
-> Int -> IntMap ByteStringRC -> (Int, IntMap ByteStringRC)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
addRef (Font -> Int
forall h a. Coercible h (Ptr a) => h -> Int
Handles.intHandle Font
font)
  where
    swap :: (b, a) -> (a, b)
swap (b
a, a
b) = (a
b, b
a)
    addRef :: Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
    addRef :: Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
addRef = \case
      Maybe ByteStringRC
Nothing -> (Int
1, ByteStringRC -> Maybe ByteStringRC
forall a. a -> Maybe a
Just (ByteStringRC -> Maybe ByteStringRC)
-> ByteStringRC -> Maybe ByteStringRC
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ByteStringRC
ByteStringRC ByteString
bytes Int
1)
      Just (ByteStringRC ByteString
oldBytes Int
oldC) -> (Int
newC, ByteStringRC -> Maybe ByteStringRC
forall a. a -> Maybe a
Just (ByteStringRC -> Maybe ByteStringRC)
-> ByteStringRC -> Maybe ByteStringRC
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ByteStringRC
ByteStringRC ByteString
oldBytes Int
newC)
        where
          newC :: Int
newC = Int
oldC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

releaseFont :: Context -> Handles.Font -> IO Int
releaseFont :: Context -> Font -> IO Int
releaseFont Context
ctx Font
font = IORef (IntMap ByteStringRC)
-> (IntMap ByteStringRC -> (IntMap ByteStringRC, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' Context
ctx.fonts ((IntMap ByteStringRC -> (IntMap ByteStringRC, Int)) -> IO Int)
-> (IntMap ByteStringRC -> (IntMap ByteStringRC, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int, IntMap ByteStringRC) -> (IntMap ByteStringRC, Int)
forall {b} {a}. (b, a) -> (a, b)
swap ((Int, IntMap ByteStringRC) -> (IntMap ByteStringRC, Int))
-> (IntMap ByteStringRC -> (Int, IntMap ByteStringRC))
-> IntMap ByteStringRC
-> (IntMap ByteStringRC, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteStringRC -> (Int, Maybe ByteStringRC))
-> Int -> IntMap ByteStringRC -> (Int, IntMap ByteStringRC)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
delRef (Font -> Int
forall h a. Coercible h (Ptr a) => h -> Int
Handles.intHandle Font
font)
  where
    swap :: (b, a) -> (a, b)
swap (b
a, a
b) = (a
b, b
a)
    delRef :: Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
    delRef :: Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
delRef = \case
      Maybe ByteStringRC
Nothing -> (-Int
1, Maybe ByteStringRC
forall a. Maybe a
Nothing)
      Just (ByteStringRC ByteString
_old Int
1) -> (Int
0, Maybe ByteStringRC
forall a. Maybe a
Nothing)
      Just (ByteStringRC ByteString
stillUsed Int
oldC) -> (Int
newC, ByteStringRC -> Maybe ByteStringRC
forall a. a -> Maybe a
Just (ByteStringRC -> Maybe ByteStringRC)
-> ByteStringRC -> Maybe ByteStringRC
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ByteStringRC
ByteStringRC ByteString
stillUsed Int
newC)
        where newC :: Int
newC = Int
oldC Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

pushFont :: Context -> Handles.Font -> IO Int
pushFont :: Context -> Font -> IO Int
pushFont Context
ctx Font
font = do
  Font
font' <- ShapeContext -> Font -> IO Font
ShapeContext.kbts_ShapePushFont Context
ctx.handle Font
font
  Context -> Font -> ByteString -> IO Int
keepFont Context
ctx Font
font' ByteString
forall a. Monoid a => a
mempty

popFont :: Context -> IO (Int, Handles.Font)
popFont :: Context -> IO (Int, Font)
popFont Context
ctx = do
  Font
font <- ShapeContext -> IO Font
ShapeContext.kbts_ShapePopFont Context
ctx.handle
  Int
kept <- Context -> Font -> IO Int
releaseFont Context
ctx Font
font
  (Int, Font) -> IO (Int, Font)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
kept, Font
font)

{- | Run the segmentation and shaping.

NB: Make sure you did load some fonts and text data!

Add content with 'text_' and 'char_', which you may wrap in feature tag sections.
-}
run :: Context -> ((?shapeContext :: Handles.ShapeContext) => IO ()) -> IO [(Run, [Glyph])]
run :: Context
-> ((?shapeContext::ShapeContext) => IO ()) -> IO [(Run, [Glyph])]
run Context
ctx (?shapeContext::ShapeContext) => IO ()
action = do
  ShapeContext -> Direction -> Language -> IO ()
ShapeContext.kbts_ShapeBegin Context
ctx.handle Direction
Enums.DIRECTION_DONT_KNOW Language
Enums.LANGUAGE_DONT_KNOW
  IO ()
shapeAction
  ShapeContext -> IO ()
ShapeContext.kbts_ShapeEnd Context
ctx.handle

  Context -> IO [(Run, [Glyph])]
iterateRun Context
ctx
  where
    shapeAction :: IO ()
shapeAction = let ?shapeContext = Context
ctx.handle in IO ()
(?shapeContext::ShapeContext) => IO ()
action

-- | Add one codepoint to the shaping run.
char_ :: (?shapeContext :: Handles.ShapeContext) => Char -> IO ()
char_ :: (?shapeContext::ShapeContext) => Char -> IO ()
char_ Char
c = ShapeContext -> CInt -> IO ()
ShapeContext.kbts_ShapeCodepoint ?shapeContext::ShapeContext
ShapeContext
?shapeContext (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c))

{- | Add a chunk of text to the shaping run.

This will not add extra characters like newlines or whitespace.
You may want to call this multiple times instead of concatentating everything.
-}
text_ :: (?shapeContext :: Handles.ShapeContext) => Text -> IO ()
text_ :: (?shapeContext::ShapeContext) => Text -> IO ()
text_ Text
t =
  Text -> (CStringLen -> IO ()) -> IO ()
forall a. Text -> (CStringLen -> IO a) -> IO a
Text.withCStringLen Text
t \(CString
strPtr, Int
strLen) ->
    ShapeContext -> CString -> CInt -> UserIdGenerationMode -> IO ()
ShapeContext.kbts_ShapeUtf8
      ?shapeContext::ShapeContext
ShapeContext
?shapeContext
      CString
strPtr
      (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
strLen)
      UserIdGenerationMode
Enums.USER_ID_GENERATION_MODE_CODEPOINT_INDEX

{- $features

The context has a feature stack that allows you to manipulate font features hierarchically.
When you give text to the context, it will apply all feature overrides that are on the
stack at the time.

If two feature overrides use the same tag, then only the latest one, i.e. the one higher
in the stack, is applied.
-}

withFeature_ :: (?shapeContext :: Handles.ShapeContext) => Enums.FeatureTag -> Int -> IO r -> IO r
withFeature_ :: forall r.
(?shapeContext::ShapeContext) =>
FeatureTag -> Int -> IO r -> IO r
withFeature_ FeatureTag
tag Int
value IO r
action = do
  ShapeContext -> FeatureTag -> CInt -> IO ()
ShapeContext.kbts_ShapePushFeature ?shapeContext::ShapeContext
ShapeContext
?shapeContext FeatureTag
tag (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
value)
  r
r <- IO r
action
  CInt
_ <- ShapeContext -> FeatureTag -> IO CInt
ShapeContext.kbts_ShapePopFeature ?shapeContext::ShapeContext
ShapeContext
?shapeContext FeatureTag
tag
  r -> IO r
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r

pushFeature_ :: (?shapeContext :: Handles.ShapeContext) => Enums.FeatureTag -> Int -> IO ()
pushFeature_ :: (?shapeContext::ShapeContext) => FeatureTag -> Int -> IO ()
pushFeature_ FeatureTag
tag Int
value = ShapeContext -> FeatureTag -> CInt -> IO ()
ShapeContext.kbts_ShapePushFeature ?shapeContext::ShapeContext
ShapeContext
?shapeContext FeatureTag
tag (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
value)

popFeature_ :: (?shapeContext :: Handles.ShapeContext) => Enums.FeatureTag -> IO Int
popFeature_ :: (?shapeContext::ShapeContext) => FeatureTag -> IO Int
popFeature_ FeatureTag
tag = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShapeContext -> FeatureTag -> IO CInt
ShapeContext.kbts_ShapePopFeature ?shapeContext::ShapeContext
ShapeContext
?shapeContext FeatureTag
tag

{- | Text runs with uniform direction and script.

The result of a text segmentation work.
-}
data Run = Run
  { Run -> Font
font :: Handles.Font
  , Run -> Script
script :: Enums.Script
  , Run -> Direction
paragraphDirection :: Enums.Direction
  , Run -> Direction
direction :: Enums.Direction
  , Run -> BreakFlags
flags :: Flags.BreakFlags
  } deriving (Run -> Run -> Bool
(Run -> Run -> Bool) -> (Run -> Run -> Bool) -> Eq Run
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Run -> Run -> Bool
== :: Run -> Run -> Bool
$c/= :: Run -> Run -> Bool
/= :: Run -> Run -> Bool
Eq, Int -> Run -> [Char] -> [Char]
[Run] -> [Char] -> [Char]
Run -> [Char]
(Int -> Run -> [Char] -> [Char])
-> (Run -> [Char]) -> ([Run] -> [Char] -> [Char]) -> Show Run
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Run -> [Char] -> [Char]
showsPrec :: Int -> Run -> [Char] -> [Char]
$cshow :: Run -> [Char]
show :: Run -> [Char]
$cshowList :: [Run] -> [Char] -> [Char]
showList :: [Run] -> [Char] -> [Char]
Show)

iterateRun :: Context -> IO [(Run, [Glyph])]
iterateRun :: Context -> IO [(Run, [Glyph])]
iterateRun Context
ctx =
  (Ptr Run -> IO [(Run, [Glyph])]) -> IO [(Run, [Glyph])]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr Run
runPtr ->
    (Ptr (Ptr Glyph) -> IO [(Run, [Glyph])]) -> IO [(Run, [Glyph])]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr Glyph)
glyphOutPtr ->
      IO Bool -> IO (Run, [Glyph]) -> IO [(Run, [Glyph])]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
stepWhile (Ptr Run -> IO Bool
step Ptr Run
runPtr) (Ptr Run -> Ptr (Ptr Glyph) -> IO (Run, [Glyph])
collect Ptr Run
runPtr Ptr (Ptr Glyph)
glyphOutPtr)
  where
    step :: Ptr Run -> IO Bool
step Ptr Run
runPtr = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShapeContext -> Ptr Run -> IO Int
ShapeContext.kbts_ShapeRun Context
ctx.handle Ptr Run
runPtr
    collect :: Ptr Run -> Ptr (Ptr Glyph) -> IO (Run, [Glyph])
collect Ptr Run
runPtr Ptr (Ptr Glyph)
glyphOutPtr = do
      Structs.Run{Script
Direction
BreakFlags
Font
GlyphIterator
font :: Font
script :: Script
paragraphDirection :: Direction
direction :: Direction
flags :: BreakFlags
glyphs :: GlyphIterator
glyphs :: Run -> GlyphIterator
flags :: Run -> BreakFlags
direction :: Run -> Direction
paragraphDirection :: Run -> Direction
script :: Run -> Script
font :: Run -> Font
..} <- Ptr Run -> IO Run
forall a. Storable a => Ptr a -> IO a
peek Ptr Run
runPtr
      (Run{Script
Direction
BreakFlags
Font
font :: Font
script :: Script
paragraphDirection :: Direction
direction :: Direction
flags :: BreakFlags
font :: Font
script :: Script
paragraphDirection :: Direction
direction :: Direction
flags :: BreakFlags
..},) ([Glyph] -> (Run, [Glyph])) -> IO [Glyph] -> IO (Run, [Glyph])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (Ptr Glyph) -> Ptr GlyphIterator -> IO [Glyph]
iterateGlyphs Ptr (Ptr Glyph)
glyphOutPtr (Ptr Run -> Ptr GlyphIterator
Structs.runGlyphIterator Ptr Run
runPtr)

iterateGlyphs :: Ptr (Ptr Structs.Glyph) -> Ptr Structs.GlyphIterator -> IO [Glyph]
iterateGlyphs :: Ptr (Ptr Glyph) -> Ptr GlyphIterator -> IO [Glyph]
iterateGlyphs Ptr (Ptr Glyph)
glyphOutPtr Ptr GlyphIterator
it = IO Bool -> IO Glyph -> IO [Glyph]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
stepWhile IO Bool
step IO Glyph
fetch
  where
    step :: IO Bool
step = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr GlyphIterator -> Ptr (Ptr Glyph) -> IO Int
Iterators.kbts_GlyphIteratorNext Ptr GlyphIterator
it Ptr (Ptr Glyph)
glyphOutPtr
    fetch :: IO Glyph
fetch = do
      Ptr (Ptr Glyph) -> IO (Ptr Glyph)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Glyph)
glyphOutPtr IO (Ptr Glyph) -> (Ptr Glyph -> IO Glyph) -> IO Glyph
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr Glyph -> IO Glyph
forall a. Storable a => Ptr a -> IO a
peek IO Glyph -> (Glyph -> IO Glyph) -> IO Glyph
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Glyph -> IO Glyph
stripGlyph

stepWhile :: Monad m => m Bool -> m a -> m [a]
stepWhile :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
stepWhile m Bool
step m a
fetch = do
  Bool
result <- m Bool
step
  if Bool
result then do
    a
x <- m a
fetch
    (a
x :) ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Bool -> m a -> m [a]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
stepWhile m Bool
step m a
fetch
  else
    [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

{- | Glyphs ready to rasterize.

The result of a text shaping work.
-}
data Glyph = Glyph
  { -- omitted: prev :: Ptr Glyph
    -- omitted: next :: Ptr Glyph
   Glyph -> Char
codepoint :: Char -- was: Word32
  , Glyph -> Word16
id :: Word16 -- ^ Glyph index. This is what you want to use to query outline data.
  , Glyph -> Word16
uid :: Word16

  , Glyph -> Int
codepointIndex :: Int -- was: userIdOrCodepointIndex

  , Glyph -> Int
offsetX :: Int
    {- ^ This, and the next few are in the "font units".
    Those have to be scaled appropriately using font metrics.
    To get the consistent results when using multiple fonts divide by 'KB.Text.Shape.Font.capHeight',
    then scale to the desired height.
    -}
  , Glyph -> Int
offsetY :: Int
  , Glyph -> Int
advanceX :: Int
  , Glyph -> Int
advanceY :: Int

  , Glyph -> Maybe Glyph
attachGlyph :: Maybe Glyph -- was: Ptr Glyph

  -- omitted: config :: Ptr () -- kbts_glyph_config *Config;

  , Glyph -> Word64
decomposition :: Word64

  , Glyph -> Word32
classes :: Word32 -- kbts_glyph_classes Classes;
  , Glyph -> GlyphFlags
flags :: Flags.GlyphFlags
  -- omitted: parentInfo :: Word32

  -- omitted: ligatureUid :: Word16
  -- omitted: ligatureComponentIndexPlusOne :: Word16
  -- omitted: ligatureComponentCount :: Word16

  -- omitted: joiningFeature :: Word8 -- kbts_joining_feature JoiningFeature;

  -- Unicode properties filled in by CodepointToGlyph.
  , Glyph -> UnicodeJoiningType
joiningType :: Enums.UnicodeJoiningType
  , Glyph -> Word8
unicodeFlags :: Word8
  , Glyph -> Word8
syllabicClass :: Word8
  , Glyph -> Word8
syllabicPosition :: Word8
  , Glyph -> Word8
useClass :: Word8
  , Glyph -> Word8
combiningClass :: Word8
  }
  deriving (Glyph -> Glyph -> Bool
(Glyph -> Glyph -> Bool) -> (Glyph -> Glyph -> Bool) -> Eq Glyph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Glyph -> Glyph -> Bool
== :: Glyph -> Glyph -> Bool
$c/= :: Glyph -> Glyph -> Bool
/= :: Glyph -> Glyph -> Bool
Eq, Int -> Glyph -> [Char] -> [Char]
[Glyph] -> [Char] -> [Char]
Glyph -> [Char]
(Int -> Glyph -> [Char] -> [Char])
-> (Glyph -> [Char]) -> ([Glyph] -> [Char] -> [Char]) -> Show Glyph
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Glyph -> [Char] -> [Char]
showsPrec :: Int -> Glyph -> [Char] -> [Char]
$cshow :: Glyph -> [Char]
show :: Glyph -> [Char]
$cshowList :: [Glyph] -> [Char] -> [Char]
showList :: [Glyph] -> [Char] -> [Char]
Show)

instance HasField "gpos" Glyph (GPOS Int) where
  {-# INLINE getField #-}
  getField :: Glyph -> GPOS Int
getField = Glyph -> GPOS Int
gpos

-- | Extract glyph positioning information.
{-# INLINE gpos #-}
gpos :: Glyph -> GPOS Int
gpos :: Glyph -> GPOS Int
gpos Glyph{Int
offsetX :: Glyph -> Int
offsetX :: Int
offsetX, Int
offsetY :: Glyph -> Int
offsetY :: Int
offsetY, Int
advanceX :: Glyph -> Int
advanceX :: Int
advanceX, Int
advanceY :: Glyph -> Int
advanceY :: Int
advanceY} = GPOS{Int
offsetX :: Int
offsetX :: Int
offsetX, Int
offsetY :: Int
offsetY :: Int
offsetY, Int
advanceX :: Int
advanceX :: Int
advanceX, Int
advanceY :: Int
advanceY :: Int
advanceY}

{- | A container for glyph positioning information.

You may want to use its Functor instance to convert between different units.
-}
data GPOS a = GPOS
  { forall a. GPOS a -> a
offsetX, forall a. GPOS a -> a
offsetY, forall a. GPOS a -> a
advanceX, forall a. GPOS a -> a
advanceY :: a
  }
  deriving (GPOS a -> GPOS a -> Bool
(GPOS a -> GPOS a -> Bool)
-> (GPOS a -> GPOS a -> Bool) -> Eq (GPOS a)
forall a. Eq a => GPOS a -> GPOS a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => GPOS a -> GPOS a -> Bool
== :: GPOS a -> GPOS a -> Bool
$c/= :: forall a. Eq a => GPOS a -> GPOS a -> Bool
/= :: GPOS a -> GPOS a -> Bool
Eq, Int -> GPOS a -> [Char] -> [Char]
[GPOS a] -> [Char] -> [Char]
GPOS a -> [Char]
(Int -> GPOS a -> [Char] -> [Char])
-> (GPOS a -> [Char])
-> ([GPOS a] -> [Char] -> [Char])
-> Show (GPOS a)
forall a. Show a => Int -> GPOS a -> [Char] -> [Char]
forall a. Show a => [GPOS a] -> [Char] -> [Char]
forall a. Show a => GPOS a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall a. Show a => Int -> GPOS a -> [Char] -> [Char]
showsPrec :: Int -> GPOS a -> [Char] -> [Char]
$cshow :: forall a. Show a => GPOS a -> [Char]
show :: GPOS a -> [Char]
$cshowList :: forall a. Show a => [GPOS a] -> [Char] -> [Char]
showList :: [GPOS a] -> [Char] -> [Char]
Show, (forall a b. (a -> b) -> GPOS a -> GPOS b)
-> (forall a b. a -> GPOS b -> GPOS a) -> Functor GPOS
forall a b. a -> GPOS b -> GPOS a
forall a b. (a -> b) -> GPOS a -> GPOS b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GPOS a -> GPOS b
fmap :: forall a b. (a -> b) -> GPOS a -> GPOS b
$c<$ :: forall a b. a -> GPOS b -> GPOS a
<$ :: forall a b. a -> GPOS b -> GPOS a
Functor)

-- | Remove the internals and pointer data
stripGlyph :: Structs.Glyph -> IO Glyph
stripGlyph :: Glyph -> IO Glyph
stripGlyph Structs.Glyph{Int
Int32
Word8
Word16
Word32
Word64
Ptr ()
Ptr Glyph
UnicodeJoiningType
UnicodeJoiningFeature
GlyphFlags
prev :: Ptr Glyph
next :: Ptr Glyph
codepoint :: Word32
id :: Word16
uid :: Word16
userIdOrCodepointIndex :: Int
offsetX :: Int32
offsetY :: Int32
advanceX :: Int32
advanceY :: Int32
attachGlyph :: Ptr Glyph
config :: Ptr ()
decomposition :: Word64
classes :: Word32
flags :: GlyphFlags
parentInfo :: Word32
ligatureUid :: Word16
ligatureComponentIndexPlusOne :: Word16
ligatureComponentCount :: Word16
joiningFeature :: UnicodeJoiningFeature
joiningType :: UnicodeJoiningType
unicodeFlags :: Word8
syllabicClass :: Word8
syllabicPosition :: Word8
useClass :: Word8
combiningClass :: Word8
markOrdering :: Word8
markOrdering :: Glyph -> Word8
combiningClass :: Glyph -> Word8
useClass :: Glyph -> Word8
syllabicPosition :: Glyph -> Word8
syllabicClass :: Glyph -> Word8
unicodeFlags :: Glyph -> Word8
joiningType :: Glyph -> UnicodeJoiningType
joiningFeature :: Glyph -> UnicodeJoiningFeature
ligatureComponentCount :: Glyph -> Word16
ligatureComponentIndexPlusOne :: Glyph -> Word16
ligatureUid :: Glyph -> Word16
parentInfo :: Glyph -> Word32
flags :: Glyph -> GlyphFlags
classes :: Glyph -> Word32
decomposition :: Glyph -> Word64
config :: Glyph -> Ptr ()
attachGlyph :: Glyph -> Ptr Glyph
advanceY :: Glyph -> Int32
advanceX :: Glyph -> Int32
offsetY :: Glyph -> Int32
offsetX :: Glyph -> Int32
userIdOrCodepointIndex :: Glyph -> Int
uid :: Glyph -> Word16
id :: Glyph -> Word16
codepoint :: Glyph -> Word32
next :: Glyph -> Ptr Glyph
prev :: Glyph -> Ptr Glyph
..} = do
  Maybe Glyph
attached <-
    if Ptr Glyph
attachGlyph Ptr Glyph -> Ptr Glyph -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Glyph
forall a. Ptr a
nullPtr then
      Maybe Glyph -> IO (Maybe Glyph)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Glyph
forall a. Maybe a
Nothing
    else
      Glyph -> Maybe Glyph
forall a. a -> Maybe a
Just (Glyph -> Maybe Glyph) -> IO Glyph -> IO (Maybe Glyph)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr Glyph -> IO Glyph
forall a. Storable a => Ptr a -> IO a
peek Ptr Glyph
attachGlyph IO Glyph -> (Glyph -> IO Glyph) -> IO Glyph
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Glyph -> IO Glyph
stripGlyph)
  Glyph -> IO Glyph
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Glyph
    { codepoint :: Char
codepoint = Int -> Char
chr (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
codepoint)
    , codepointIndex :: Int
codepointIndex = Int
userIdOrCodepointIndex -- XXX: always codepoint when using context api
    , attachGlyph :: Maybe Glyph
attachGlyph = Maybe Glyph
attached
    , offsetX :: Int
offsetX = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
offsetX
    , offsetY :: Int
offsetY = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
offsetY
    , advanceX :: Int
advanceX = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
advanceX
    , advanceY :: Int
advanceY = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
advanceY
    , Word8
Word16
Word32
Word64
UnicodeJoiningType
GlyphFlags
id :: Word16
uid :: Word16
decomposition :: Word64
classes :: Word32
flags :: GlyphFlags
joiningType :: UnicodeJoiningType
unicodeFlags :: Word8
syllabicClass :: Word8
syllabicPosition :: Word8
useClass :: Word8
combiningClass :: Word8
id :: Word16
uid :: Word16
decomposition :: Word64
classes :: Word32
flags :: GlyphFlags
joiningType :: UnicodeJoiningType
unicodeFlags :: Word8
syllabicClass :: Word8
syllabicPosition :: Word8
useClass :: Word8
combiningClass :: Word8
..
    }