Shape.hs

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
  , Handles.ShapeContext
  , text_
  , char_
  , withFont_
    -- $features
  , withFeature_
  , pushFeature_
  , popFeature_
    -- * Internals
  , stripGlyph
  ) where

import Control.Monad
import Data.IORef
import Foreign hiding (void)
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 = bracket createContext destroyContext

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

data ByteStringRC = ByteStringRC ByteString Int

createContext :: IO Context
createContext = do
  handle <- ShapeContext.kbts_CreateShapeContext nullFunPtr nullPtr
  when (handle == Handles.ShapeContext nullPtr) $
    -- XXX: assuming the default allocator didn't allocate anything yet
    error "kbts_CreateShapeContext: failed to init"
  fonts <- newIORef mempty
  pure Context{handle, fonts}

destroyContext :: Context -> IO ()
destroyContext Context{handle} = ShapeContext.kbts_DestroyShapeContext 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 ctx path fontIndex = do
  font <- withCString path \pathPtr ->
    ShapeContext.kbts_ShapePushFontFromFile ctx.handle pathPtr (fromIntegral fontIndex)
  let err = ShapeContext.kbts_ShapeError ctx.handle
  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
  pure font

pushFontFromMemory :: Context -> ByteString -> Int -> IO Handles.Font
pushFontFromMemory ctx fontData fontIndex =
  ByteString.unsafeUseAsCStringLen fontData \(memoryPtr, memorySize) -> do
    font <- ShapeContext.kbts_ShapePushFontFromMemory ctx.handle (castPtr memoryPtr) (fromIntegral memorySize)  (fromIntegral fontIndex)
    let err = ShapeContext.kbts_ShapeError ctx.handle
    when (err /= Enums.SHAPE_ERROR_NONE) $
        error $ "kbts_ShapePushFontFromMemory: failed to load font. " <> show err
    _ <- keepFont ctx font fontData
    pure font

keepFont :: Context -> Handles.Font -> ByteString -> IO Int
keepFont ctx font bytes = atomicModifyIORef' ctx.fonts $ swap . IntMap.alterF addRef (Handles.intHandle font)
  where
    swap (a, b) = (b, a)
    addRef :: Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
    addRef = \case
      Nothing -> (1, Just $ ByteStringRC bytes 1)
      Just (ByteStringRC oldBytes oldC) -> (newC, Just $ ByteStringRC oldBytes newC)
        where
          newC = oldC + 1

releaseFont :: Context -> Handles.Font -> IO Int
releaseFont ctx font = atomicModifyIORef' ctx.fonts $ swap . IntMap.alterF delRef (Handles.intHandle font)
  where
    swap (a, b) = (b, a)
    delRef :: Maybe ByteStringRC -> (Int, Maybe ByteStringRC)
    delRef = \case
      Nothing -> (-1, Nothing)
      Just (ByteStringRC _old 1) -> (0, Nothing)
      Just (ByteStringRC stillUsed oldC) -> (newC, Just $ ByteStringRC stillUsed newC)
        where newC = oldC - 1

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

popFont :: Context -> IO (Int, Handles.Font)
popFont ctx = do
  font <- ShapeContext.kbts_ShapePopFont ctx.handle
  kept <- releaseFont ctx font
  pure (kept, 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 ctx action = do
  ShapeContext.kbts_ShapeBegin ctx.handle Enums.DIRECTION_DONT_KNOW Enums.LANGUAGE_DONT_KNOW
  shapeAction
  ShapeContext.kbts_ShapeEnd ctx.handle

  iterateRun ctx
  where
    shapeAction = let ?shapeContext = ctx.handle in action

-- | Add one codepoint to the shaping run.
char_ :: (?shapeContext :: Handles.ShapeContext) => Char -> IO ()
char_ c = ShapeContext.kbts_ShapeCodepoint ?shapeContext (fromIntegral (ord 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_ t =
  Text.withCStringLen t \(strPtr, strLen) ->
    ShapeContext.kbts_ShapeUtf8
      ?shapeContext
      strPtr
      (fromIntegral strLen)
      Enums.USER_ID_GENERATION_MODE_CODEPOINT_INDEX

{- | Run a section with extra fonts on the stack.

The text added here will first consider the new font.
This may be used to implement text styles by pushing bold/italic variants.
-}
withFont_ :: (?shapeContext :: Handles.ShapeContext) => Handles.Font -> IO () -> IO ()
withFont_ f action = do
  void $! ShapeContext.kbts_ShapePushFont ?shapeContext f
  action
  void $! ShapeContext.kbts_ShapePopFont ?shapeContext

{- $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_ tag value action = do
  pushFeature_ tag value
  r <- action
  _ <- popFeature_ tag
  pure r

pushFeature_ :: (?shapeContext :: Handles.ShapeContext) => Enums.FeatureTag -> Int -> IO ()
pushFeature_ tag value = ShapeContext.kbts_ShapePushFeature ?shapeContext tag (fromIntegral value)

popFeature_ :: (?shapeContext :: Handles.ShapeContext) => Enums.FeatureTag -> IO Int
popFeature_ tag = fromIntegral <$> ShapeContext.kbts_ShapePopFeature ?shapeContext tag

{- | Text runs with uniform direction and script.

The result of a text segmentation work.
-}
data Run = Run
  { font :: Handles.Font
  , script :: Enums.Script
  , paragraphDirection :: Enums.Direction
  , direction :: Enums.Direction
  , flags :: Flags.BreakFlags
  } deriving (Eq, Show)

iterateRun :: Context -> IO [(Run, [Glyph])]
iterateRun ctx =
  alloca \runPtr ->
    alloca \glyphOutPtr ->
      stepWhile (step runPtr) (collect runPtr glyphOutPtr)
  where
    step runPtr = (/= 0) <$> ShapeContext.kbts_ShapeRun ctx.handle runPtr
    collect runPtr glyphOutPtr = do
      Structs.Run{..} <- peek runPtr
      (Run{..},) <$> iterateGlyphs glyphOutPtr (Structs.runGlyphIterator runPtr)

iterateGlyphs :: Ptr (Ptr Structs.Glyph) -> Ptr Structs.GlyphIterator -> IO [Glyph]
iterateGlyphs glyphOutPtr it = stepWhile step fetch
  where
    step = (/= 0) <$> Iterators.kbts_GlyphIteratorNext it glyphOutPtr
    fetch = do
      peek glyphOutPtr >>= peek >>= stripGlyph

stepWhile :: Monad m => m Bool -> m a -> m [a]
stepWhile step fetch = do
  result <- step
  if result then do
    x <- fetch
    (x :) <$> stepWhile step fetch
  else
    pure []

{- | Glyphs ready to rasterize.

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

  , codepointIndex :: Int -- was: userIdOrCodepointIndex

  , 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.
    -}
  , offsetY :: Int
  , advanceX :: Int
  , advanceY :: Int

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

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

  , decomposition :: Word64

  , classes :: Word32 -- kbts_glyph_classes Classes;
  , 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.
  , joiningType :: Enums.UnicodeJoiningType
  , unicodeFlags :: Word8
  , syllabicClass :: Word8
  , syllabicPosition :: Word8
  , useClass :: Word8
  , combiningClass :: Word8
  }
  deriving (Eq, Show)

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

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

{- | A container for glyph positioning information.

You may want to use its Functor instance to convert between different units.
-}
data GPOS a = GPOS
  { offsetX, offsetY, advanceX, advanceY :: a
  }
  deriving (Eq, Show, Functor)

-- | Remove the internals and pointer data
stripGlyph :: Structs.Glyph -> IO Glyph
stripGlyph Structs.Glyph{..} = do
  attached <-
    if attachGlyph == nullPtr then
      pure Nothing
    else
      Just <$> (peek attachGlyph >>= stripGlyph)
  pure Glyph
    { codepoint = chr (fromIntegral codepoint)
    , codepointIndex = userIdOrCodepointIndex -- XXX: always codepoint when using context api
    , attachGlyph = attached
    , offsetX = fromIntegral offsetX
    , offsetY = fromIntegral offsetY
    , advanceX = fromIntegral advanceX
    , advanceY = fromIntegral advanceY
    , ..
    }