Structs.hsc

module KB.Text.Shape.FFI.Structs where

import Prelude hiding (id, error)

import Foreign
import Foreign.C

import KB.Text.Shape.FFI.Allocator (Allocator)
import KB.Text.Shape.FFI.Enums
import KB.Text.Shape.FFI.Flags
import KB.Text.Shape.FFI.Handles

#include "kb_text_shape.h"

data FontInfo = FontInfo
  { strings :: [Ptr CChar] -- ^ @char *Strings[KBTS_FONT_INFO_STRING_ID_COUNT]@
  , stringLengths :: [Word16] -- ^ @kbts_u16 StringLengths[KBTS_FONT_INFO_STRING_ID_COUNT]@

  , styleFlags :: FontStyleFlags
  , weight :: FontWeight
  , width :: FontWidth
  } deriving (Eq, Show)

instance Storable FontInfo where
  alignment ~_ = #alignment kbts_font_info
  sizeOf ~_ = #size kbts_font_info

  peek ptr = do
    strings <- peekArray FONT_INFO_STRING_ID_COUNT $ ptr `plusPtr` (#offset kbts_font_info, Strings)
    stringLengths <- peekArray FONT_INFO_STRING_ID_COUNT $ ptr `plusPtr` (#offset kbts_font_info, StringLengths)
    styleFlags <- (#peek kbts_font_info, StyleFlags) ptr
    weight <- (#peek kbts_font_info, Weight) ptr
    width <- (#peek kbts_font_info, Width) ptr
    pure FontInfo{..}

  poke ptr FontInfo{..} = do
    pokeArray (ptr `plusPtr` (#offset kbts_font_info, Strings)) strings
    pokeArray (ptr `plusPtr` (#offset kbts_font_info, StringLengths)) stringLengths
    (#poke kbts_font_info, StyleFlags) ptr styleFlags
    (#poke kbts_font_info, Weight) ptr weight
    (#poke kbts_font_info, Width) ptr width

data GlyphIterator = GlyphIterator
  { glyphStorage :: Ptr GlyphStorage
  , currentGlyph :: Ptr Glyph

  , lastAdvanceX :: Int
  , x :: Int
  , y :: Int
  }
  deriving (Show)

instance Storable GlyphIterator where
  alignment ~_ = #alignment kbts_glyph_iterator
  sizeOf ~_ = #size kbts_glyph_iterator

  peek ptr = do
    glyphStorage <- (#peek kbts_glyph_iterator, GlyphStorage) ptr
    currentGlyph <- (#peek kbts_glyph_iterator, CurrentGlyph) ptr
    lastAdvanceX <- fromIntegral @CInt <$> (#peek kbts_glyph_iterator, LastAdvanceX) ptr
    x <- fromIntegral @CInt <$> (#peek kbts_glyph_iterator, X) ptr
    y <- fromIntegral @CInt <$> (#peek kbts_glyph_iterator, Y) ptr
    pure GlyphIterator{..}

  poke ptr GlyphIterator{..} = do
    (#poke kbts_glyph_iterator, GlyphStorage) ptr glyphStorage
    (#poke kbts_glyph_iterator, CurrentGlyph) ptr currentGlyph
    (#poke kbts_glyph_iterator, LastAdvanceX) ptr $ fromIntegral @_ @CInt lastAdvanceX
    (#poke kbts_glyph_iterator, X) ptr $ fromIntegral @_ @CInt x
    (#poke kbts_glyph_iterator, Y) ptr $ fromIntegral @_ @CInt y

data CodepointIterator = CodepointIterator
  { codepoint :: Ptr Codepoint
  , context :: ShapeContext

  , endBlockIndex :: Word32
  , onePastLastCodepointIndex :: Word32
  , blockIndex :: Word32
  , codepointIndex :: Word32
  , currentBlockCodepointCount :: Word32
  , flatCodepointIndex :: Word32
  }
  deriving (Show)

instance Storable CodepointIterator where
  alignment ~_ = #alignment kbts_shape_codepoint_iterator
  sizeOf ~_ = #size kbts_shape_codepoint_iterator

  peek ptr = do
    codepoint <- (#peek kbts_shape_codepoint_iterator, Codepoint) ptr
    context <- (#peek kbts_shape_codepoint_iterator, Context) ptr
    endBlockIndex <- (#peek kbts_shape_codepoint_iterator, EndBlockIndex) ptr
    onePastLastCodepointIndex <- (#peek kbts_shape_codepoint_iterator, OnePastLastCodepointIndex) ptr
    blockIndex <- (#peek kbts_shape_codepoint_iterator, BlockIndex) ptr
    codepointIndex <- (#peek kbts_shape_codepoint_iterator, CodepointIndex) ptr
    currentBlockCodepointCount <- (#peek kbts_shape_codepoint_iterator, CurrentBlockCodepointCount) ptr
    flatCodepointIndex <- (#peek kbts_shape_codepoint_iterator, FlatCodepointIndex) ptr
    pure CodepointIterator{..}

  poke ptr CodepointIterator{..} = do
    (#poke kbts_shape_codepoint_iterator, Codepoint) ptr codepoint
    (#poke kbts_shape_codepoint_iterator, Context) ptr context
    (#poke kbts_shape_codepoint_iterator, EndBlockIndex) ptr endBlockIndex
    (#poke kbts_shape_codepoint_iterator, OnePastLastCodepointIndex) ptr onePastLastCodepointIndex
    (#poke kbts_shape_codepoint_iterator, BlockIndex) ptr blockIndex
    (#poke kbts_shape_codepoint_iterator, CodepointIndex) ptr codepointIndex
    (#poke kbts_shape_codepoint_iterator, CurrentBlockCodepointCount) ptr currentBlockCodepointCount
    (#poke kbts_shape_codepoint_iterator, FlatCodepointIndex) ptr flatCodepointIndex

data Run = Run
  { font :: Font
  , script :: Script
  , paragraphDirection :: Direction
  , direction :: Direction
  , flags :: BreakFlags

  , glyphs :: GlyphIterator
  }
  deriving (Show)

runGlyphIterator :: Ptr Run -> Ptr GlyphIterator
runGlyphIterator runPtr = runPtr `plusPtr` (#offset kbts_run, Glyphs)

instance Storable Run where
  alignment ~_ = #alignment kbts_run
  sizeOf ~_ = #size kbts_run

  peek ptr = do
    font <- (#peek kbts_run, Font) ptr
    script <- (#peek kbts_run, Script) ptr
    paragraphDirection <- (#peek kbts_run, ParagraphDirection) ptr
    direction <- (#peek kbts_run, Direction) ptr
    flags <- (#peek kbts_run, Flags) ptr

    glyphs <- (#peek kbts_run, Glyphs) ptr
    pure Run{..}

  poke ptr Run{..} = do
    (#poke kbts_run, Font) ptr font
    (#poke kbts_run, Script) ptr script
    (#poke kbts_run, ParagraphDirection) ptr paragraphDirection
    (#poke kbts_run, Direction) ptr direction
    (#poke kbts_run, Flags) ptr flags
    (#poke kbts_run, Glyphs) ptr glyphs

data Arena = Arena
  { allocator :: FunPtr Allocator
  , allocatorData :: Ptr ()

  , blockSentinel :: ArenaBlockHeader
  , freeBlockSentinel :: ArenaBlockHeader
  , error :: Int
  }
  deriving (Show)

instance Storable Arena where
  alignment ~_ = #alignment kbts_arena
  sizeOf ~_ = #size kbts_arena
  peek ptr = do
    allocator <- (#peek kbts_arena, Allocator) ptr
    allocatorData <- (#peek kbts_arena, AllocatorData) ptr
    blockSentinel <- (#peek kbts_arena, BlockSentinel) ptr
    freeBlockSentinel <- (#peek kbts_arena, FreeBlockSentinel) ptr
    error <- (#peek kbts_arena, Error) ptr
    pure Arena{..}
  poke ptr Arena{..} = do
    (#poke kbts_arena, Allocator) ptr allocator
    (#poke kbts_arena, AllocatorData) ptr allocatorData
    (#poke kbts_arena, BlockSentinel) ptr blockSentinel
    (#poke kbts_arena, FreeBlockSentinel) ptr freeBlockSentinel
    (#poke kbts_arena, Error) ptr error

data ArenaBlockHeader = ArenaBlockHeader
  { prev :: Ptr ArenaBlockHeader
  , next :: Ptr ArenaBlockHeader
  }
  deriving (Show)

instance Storable ArenaBlockHeader where
  alignment ~_ = #alignment kbts_arena_block_header
  sizeOf ~_ = #size kbts_arena_block_header
  peek ptr = do
    prev <- (#peek kbts_arena_block_header, Prev) ptr
    next <- (#peek kbts_arena_block_header, Next) ptr
    pure ArenaBlockHeader{..}
  poke ptr ArenaBlockHeader{..} = do
    (#poke kbts_arena_block_header, Prev) ptr prev
    (#poke kbts_arena_block_header, Next) ptr next

data GlyphStorage = GlyphStorage
  { arena :: Arena

  , glyphSentinel :: Glyph
  , freeGlyphSentinel :: Glyph
  }
  deriving (Show)

instance Storable GlyphStorage where
  alignment ~_ = #alignment kbts_glyph_storage
  sizeOf ~_ = #size kbts_glyph_storage
  peek ptr = do
    arena <- (#peek kbts_glyph_storage, Arena) ptr
    glyphSentinel <- (#peek kbts_glyph_storage, GlyphSentinel) ptr
    freeGlyphSentinel <- (#peek kbts_glyph_storage, FreeGlyphSentinel) ptr
    pure GlyphStorage{..}
  poke ptr GlyphStorage{..} = do
    (#poke kbts_glyph_storage, Arena) ptr arena
    (#poke kbts_glyph_storage, GlyphSentinel) ptr glyphSentinel
    (#poke kbts_glyph_storage, FreeGlyphSentinel) ptr freeGlyphSentinel

data Glyph = Glyph
  { prev :: Ptr Glyph
  , next :: Ptr Glyph

  , codepoint :: Word32
  , id :: Word16 -- ^ Glyph index. This is what you want to use to query outline data.
  , uid :: Word16

  , userIdOrCodepointIndex :: Int
    {- ^ This field is kept and returned as-is throughout the shaping process.

    When you are using the context API, it contains a codepoint index always!
    To get the original user ID with the context API, you need to get the corresponding kbts_shape_codepoint
    with kbts_ShapeGetShapeCodepoint(Context, Glyph->UserIdOrCodepointIndex, ...);
    -}

  -- Used by GPOS
  , offsetX :: Int32
  , offsetY :: Int32
  , advanceX :: Int32
  , advanceY :: Int32

  , attachGlyph :: Ptr Glyph
  {- ^ Set by GPOS attachments

    Earlier on, we used to assume that, if a glyph had no advance, or had the MARK glyph class, then
    it could be handled as a mark in layout operations. This is inaccurate.
    Unicode makes a distinction between attached marks and standalone marks. For our purposes, attached
    marks are marks that have found a valid base character to attach to. In practice, this means that the
    font contains a valid display position/configuration for it in the current context.
    In contrast, standalone marks are marks that aren't attached to anything. Fonts may still have glyphs
    for them, in which case we want to display those just like regular glyphs that take up horizontal space
    on the line. When fonts don't have glyphs for them, they simply stay around as zero-width glyphs.
    Standalone marks have notably different behavior compared to attached marks, and so, once we start
    applying positioning features, it becomes worthwhile to track exactly which glyph has attached to which.
  -}

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

  , decomposition :: Word64

  , classes :: Word32 -- kbts_glyph_classes Classes;
  , flags :: GlyphFlags -- kbts_glyph_flags Flags;
  , parentInfo :: Word32

  , ligatureUid :: Word16
    {- ^ This is set by GSUB and used by GPOS.
      A 0-index means that we should attach to the last component in the ligature.

      From the Microsoft docs:
        To correctly access the subtables, the client must keep track of the component associated with the mark.

        For a given mark assigned to a particular class, the appropriate base attachment point is determined by which
        ligature component the mark is associated with. This is dependent on the original character string and subsequent
        character- or glyph-sequence processing, not the font data alone. While a text-layout client is performing any
        character-based preprocessing or any glyph-substitution operations using the GSUB table, the text-layout client
        must keep track of associations of marks to particular ligature-glyph components.
    -}

  , ligatureComponentIndexPlusOne :: Word16
  , ligatureComponentCount :: Word16

  , joiningFeature :: UnicodeJoiningFeature
    -- ^ Set in GSUB and used in GPOS, for STCH.

  -- Unicode properties filled in by CodepointToGlyph.
  , joiningType :: UnicodeJoiningType
  , unicodeFlags :: Word8
  , syllabicClass :: Word8
  , syllabicPosition :: Word8
  , useClass :: Word8
  , combiningClass :: Word8

  , markOrdering :: Word8 -- ^ Only used temporarily in NORMALIZE for Arabic mark reordering.
  }
  deriving (Show)

instance Storable Glyph where
  alignment ~_ = #alignment kbts_glyph
  sizeOf ~_ = #size kbts_glyph

  peek ptr = do
    prev <- (#peek kbts_glyph, Prev) ptr
    next <- (#peek kbts_glyph, Next) ptr
    codepoint <- (#peek kbts_glyph, Codepoint) ptr
    id <- (#peek kbts_glyph, Id) ptr
    uid <- (#peek kbts_glyph, Uid) ptr
    userIdOrCodepointIndex <- fromIntegral @CInt <$> (#peek kbts_glyph, UserIdOrCodepointIndex) ptr
    offsetX <- (#peek kbts_glyph, OffsetX) ptr
    offsetY <- (#peek kbts_glyph, OffsetY) ptr
    advanceX <- (#peek kbts_glyph, AdvanceX) ptr
    advanceY <- (#peek kbts_glyph, AdvanceY) ptr
    attachGlyph <- (#peek kbts_glyph, AttachGlyph) ptr
    config <- (#peek kbts_glyph, Config) ptr
    decomposition <- (#peek kbts_glyph, Decomposition) ptr
    classes <- (#peek kbts_glyph, Classes) ptr
    flags <- (#peek kbts_glyph, Flags) ptr
    parentInfo <- (#peek kbts_glyph, ParentInfo) ptr
    ligatureUid <- (#peek kbts_glyph, LigatureUid) ptr
    ligatureComponentIndexPlusOne <- (#peek kbts_glyph, LigatureComponentIndexPlusOne) ptr
    ligatureComponentCount <- (#peek kbts_glyph, LigatureComponentCount) ptr
    joiningFeature <- (#peek kbts_glyph, JoiningFeature) ptr
    joiningType <- (#peek kbts_glyph, JoiningType) ptr
    unicodeFlags <- (#peek kbts_glyph, UnicodeFlags) ptr
    syllabicClass <- (#peek kbts_glyph, SyllabicClass) ptr
    syllabicPosition <- (#peek kbts_glyph, SyllabicPosition) ptr
    useClass <- (#peek kbts_glyph, UseClass) ptr
    combiningClass <- (#peek kbts_glyph, CombiningClass) ptr
    markOrdering <- (#peek kbts_glyph, MarkOrdering) ptr
    pure Glyph{..}

  poke ptr Glyph{..} = do
    (#poke kbts_glyph, Prev) ptr prev
    (#poke kbts_glyph, Next) ptr next
    (#poke kbts_glyph, Codepoint) ptr codepoint
    (#poke kbts_glyph, Id) ptr id
    (#poke kbts_glyph, Uid) ptr uid
    (#poke kbts_glyph, UserIdOrCodepointIndex) ptr $ fromIntegral @_ @CInt userIdOrCodepointIndex
    (#poke kbts_glyph, OffsetX) ptr offsetX
    (#poke kbts_glyph, OffsetY) ptr offsetY
    (#poke kbts_glyph, AdvanceX) ptr advanceX
    (#poke kbts_glyph, AdvanceY) ptr advanceY
    (#poke kbts_glyph, AttachGlyph) ptr attachGlyph
    (#poke kbts_glyph, Config) ptr config
    (#poke kbts_glyph, Decomposition) ptr decomposition
    (#poke kbts_glyph, Classes) ptr classes
    (#poke kbts_glyph, Flags) ptr flags
    (#poke kbts_glyph, ParentInfo) ptr parentInfo
    (#poke kbts_glyph, LigatureUid) ptr ligatureUid
    (#poke kbts_glyph, LigatureComponentIndexPlusOne) ptr ligatureComponentIndexPlusOne
    (#poke kbts_glyph, LigatureComponentCount) ptr ligatureComponentCount
    (#poke kbts_glyph, JoiningFeature) ptr joiningFeature
    (#poke kbts_glyph, JoiningType) ptr joiningType
    (#poke kbts_glyph, UnicodeFlags) ptr unicodeFlags
    (#poke kbts_glyph, SyllabicClass) ptr syllabicClass
    (#poke kbts_glyph, SyllabicPosition) ptr syllabicPosition
    (#poke kbts_glyph, UseClass) ptr useClass
    (#poke kbts_glyph, CombiningClass) ptr combiningClass

data Codepoint = Codepoint
  { font :: Font -- ^ Only set when @(BreakFlags & KBTS_BREAK_FLAG_GRAPHEME) != 0@.
  , config :: Ptr () -- kbts_glyph_config*

  , codepoint :: Int
  , userId :: Int

  , breakFlags :: BreakFlags
  , script :: Script -- ^ Only set when @(BreakFlags & KBTS_BREAK_FLAG_SCRIPT) != 0@.
  , direction :: Direction -- ^ Only set when @(BreakFlags & KBTS_BREAK_FLAG_DIRECTION) != 0@.
  , paragraphDirection :: Direction -- ^ Only set when @(BreakFlags & KBTS_BREAK_FLAG_PARAGRAPH_DIRECTION) != 0@.
  }
  deriving (Show)

instance Storable Codepoint where
  alignment ~_ = #alignment kbts_shape_codepoint
  sizeOf ~_ = #size kbts_shape_codepoint

  peek ptr = do
    font <- (#peek kbts_shape_codepoint, Font) ptr
    config <- (#peek kbts_shape_codepoint, Config) ptr
    codepoint <- fromIntegral @CInt <$> (#peek kbts_shape_codepoint, Codepoint) ptr
    userId <- fromIntegral @CInt <$> (#peek kbts_shape_codepoint, UserId) ptr
    breakFlags <- (#peek kbts_shape_codepoint, BreakFlags) ptr
    script <- (#peek kbts_shape_codepoint, Script) ptr
    direction <- (#peek kbts_shape_codepoint, Direction) ptr
    paragraphDirection <- (#peek kbts_shape_codepoint, ParagraphDirection) ptr
    pure Codepoint{..}

  poke ptr Codepoint{..} = do
    (#poke kbts_shape_codepoint, Font) ptr font
    (#poke kbts_shape_codepoint, Codepoint) ptr $ fromIntegral @_ @CInt codepoint
    (#poke kbts_shape_codepoint, UserId) ptr $ fromIntegral @_ @CInt userId
    (#poke kbts_shape_codepoint, BreakFlags) ptr breakFlags
    (#poke kbts_shape_codepoint, Script) ptr script
    (#poke kbts_shape_codepoint, Direction) ptr direction
    (#poke kbts_shape_codepoint, ParagraphDirection) ptr paragraphDirection

data FeatureOverride = FeatureOverride
  { tag :: FeatureTag
  , value :: Int
  }
  deriving (Eq, Ord, Show)

instance Storable FeatureOverride where
  alignment ~_ = #alignment kbts_feature_override
  sizeOf ~_ = #size kbts_feature_override
  peek ptr = do
    tag <- peekByteOff ptr (#offset kbts_feature_override, Tag)
    value <- fromIntegral @CInt <$> peekByteOff ptr (#offset kbts_feature_override, Value)
    pure FeatureOverride{..}
  poke ptr FeatureOverride{..} = do
    pokeByteOff ptr (#offset kbts_feature_override, Tag) tag
    pokeByteOff ptr (#offset kbts_feature_override, Value) $ fromIntegral @_ @CInt value

data GlyphParent = GlyphParent
  { decomposition :: Word64
  , codepoint :: Word32
  }
  deriving (Eq, Ord, Show)

instance Storable GlyphParent where
  alignment ~_ = #alignment kbts_glyph_parent
  sizeOf ~_ = #size kbts_glyph_parent
  peek ptr = do
    decomposition <- (#peek kbts_glyph_parent, Decomposition) ptr
    codepoint <- (#peek kbts_glyph_parent, Codepoint) ptr
    pure GlyphParent{..}
  poke ptr GlyphParent{..} = do
    (#poke kbts_glyph_parent, Decomposition) ptr decomposition
    (#poke kbts_glyph_parent, Codepoint) ptr codepoint

pattern MAXIMUM_RECOMPOSITION_PARENTS :: Int
pattern MAXIMUM_RECOMPOSITION_PARENTS = #const KBTS_MAXIMUM_RECOMPOSITION_PARENTS

data FontCoverageTest = FontCoverageTest
  { font :: Font
  , baseCodepoint :: Word32

  , currentBaseError :: Int
  , error :: Int

  , baseParents :: Ptr GlyphParent -- ^ @kbts_glyph_parent BaseParents[KBTS_MAXIMUM_RECOMPOSITION_PARENTS];@
  , baseParentCount :: Word32
  }
  deriving (Show)

instance Storable FontCoverageTest where
  alignment ~_ = #alignment kbts_font_coverage_test
  sizeOf ~_ = #size kbts_font_coverage_test
  peek ptr = do
    font <- (#peek kbts_font_coverage_test, Font) ptr
    baseCodepoint <- (#peek kbts_font_coverage_test, BaseCodepoint) ptr
    currentBaseError <- fromIntegral @CInt <$> (#peek kbts_font_coverage_test, CurrentBaseError) ptr
    error <- fromIntegral @CInt <$> (#peek kbts_font_coverage_test, Error) ptr
    baseParents <- (#peek kbts_font_coverage_test, BaseParents) ptr
    baseParentCount <- (#peek kbts_font_coverage_test, BaseParentCount) ptr
    pure FontCoverageTest{..}
  poke ptr FontCoverageTest{..} = do
    (#poke kbts_font_coverage_test, Font) ptr font
    (#poke kbts_font_coverage_test, BaseCodepoint) ptr baseCodepoint
    (#poke kbts_font_coverage_test, CurrentBaseError) ptr $ fromIntegral @_ @CInt currentBaseError
    (#poke kbts_font_coverage_test, Error) ptr $ fromIntegral @_ @CInt error
    (#poke kbts_font_coverage_test, BaseParents) ptr baseParents
    (#poke kbts_font_coverage_test, BaseParentCount) ptr baseParentCount

data Break = Break
  { position :: Int
    {- ^
      The break code mostly works in relative positions, but we convert to absolute positions for the user.
      That way, breaks can be trivially stored and compared and such and it just works.
    -}
  , flags :: BreakFlags
  , direction :: Direction -- ^ Only valid if 'KBTS_BREAK_FLAG_DIRECTION' is set.
  , paragraphDirection :: Direction -- ^ Only valid if 'KBTS_BREAK_FLAG_PARAGRAPH_DIRECTION' is set.
  , script :: Script -- ^ Only valid if 'KBTS_BREAK_FLAG_SCRIPT' is set.
  }
  deriving (Show, Eq)

instance Storable Break where
  alignment ~_ = #alignment kbts_break
  sizeOf ~_ = #size kbts_break
  peek ptr = do
    position <- fromIntegral @CInt <$> (#peek kbts_break, Position) ptr
    flags <- (#peek kbts_break, Flags) ptr
    direction <- (#peek kbts_break, Direction) ptr
    paragraphDirection <- (#peek kbts_break, ParagraphDirection) ptr
    script <- (#peek kbts_break, Script) ptr
    pure Break{..}
  poke ptr Break{..} = do
    (#poke kbts_break, Position) ptr $ fromIntegral @_ @CInt position
    (#poke kbts_break, Flags) ptr flags
    (#poke kbts_break, Direction) ptr direction
    (#poke kbts_break, ParagraphDirection) ptr paragraphDirection
    (#poke kbts_break, Script) ptr script