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

    -- ** Adding fonts
  , pushFontFromFile
  , pushFont
  , popFont

    -- * Turning texts into glyphs
  , run
  , text_
  , char_
  , withFeature_
  , pushFeature_
  , popFeature_
  , Run(..)
  , Glyph(..)
    -- * Internals
  , stripGlyph
  ) where

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

import Control.Exception (bracket, finally, onException)
import Data.Char (ord)
import Data.List qualified as List
import Data.Text (Text)
import Data.Text.Foreign qualified as Text

import KB.Text.Shape.FFI.API.Context qualified as ShapeContext
import KB.Text.Shape.FFI.Enums qualified as Enums
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
  { memory :: Ptr ()
  , handle :: Handles.ShapeContext
  , fonts :: IORef [Handles.Font]
  }

createContext :: IO Context
createContext = do
  memory <- callocBytes kbtsTotalSize
  flip onException (free memory) do
    handle <- ShapeContext.kbts_CreateShapeContext nullFunPtr nullPtr
    when (handle == Handles.ShapeContext nullPtr) $
      -- XXX: assuming the default allocator didn't allocate anything yet
      error "kbts_PlaceShapeContextFixedMemory: failed to init"
    fonts <- newIORef []
    pure Context{memory, handle, fonts}
  where
    kbtsTotalSize = fromIntegral ShapeContext.kbts_SizeOfShapeContext + sizeOf (undefined :: Structs.Arena)

destroyContext :: Context -> IO ()
destroyContext ctx =
 ShapeContext.kbts_DestroyShapeContext ctx.handle `finally` free ctx.memory

pushFontFromFile :: Context -> FilePath -> Int -> IO Handles.Font
pushFontFromFile ctx path fontIndex = do
  withCString path \fileNamePtr -> do
    font <- ShapeContext.kbts_ShapePushFontFromFile ctx.handle fileNamePtr (fromIntegral fontIndex)
    let err = ShapeContext.kbts_ShapeError ctx.handle
    when (err /= Enums.SHAPE_ERROR_NONE) $
        error $ "kbts_ShapePushFontFromFile: failed to load font. " <> show err
    atomicModifyIORef' ctx.fonts \fs ->
      ( font : fs
      , font
      )

pushFont :: Context -> Handles.Font -> IO ()
pushFont ctx font = do
  _ <- ShapeContext.kbts_ShapePushFont ctx.handle font
  atomicModifyIORef' ctx.fonts \fs ->
    ( font : fs
    , ()
    )

popFont :: Context -> IO Handles.Font
popFont ctx = ShapeContext.kbts_ShapePopFont ctx.handle

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

char_ :: (?shapeContext :: Handles.ShapeContext) => Char -> IO ()
char_ c = ShapeContext.kbts_ShapeCodepoint ?shapeContext (fromIntegral (ord c))

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

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

withFeature_ :: (?shapeContext :: Handles.ShapeContext) => Enums.FeatureTag -> Int -> IO r -> IO r
withFeature_ tag value action = do
  ShapeContext.kbts_ShapePushFeature ?shapeContext tag (fromIntegral value)
  r <- action
  _ <- ShapeContext.kbts_ShapePopFeature ?shapeContext tag
  pure r

data Run = Run
  { fontIndex :: Maybe Int
  , script :: Enums.Script
  , paragraphDirection :: Enums.Direction
  , direction :: Enums.Direction
  , flags :: Enums.BreakFlags
  } deriving (Eq, Show)

iterateRun :: Context -> IO [(Run, [Glyph])]
iterateRun ctx =
  alloca \runPtr -> do
    alloca \glyphOutPtr -> do
      fonts <- readIORef ctx.fonts
      stepWhile (step runPtr) (collect fonts runPtr glyphOutPtr)
  where
    step runPtr = (/= 0) <$> ShapeContext.kbts_ShapeRun ctx.handle runPtr
    collect fonts runPtr glyphOutPtr = do
      Structs.Run{..} <- peek runPtr
      let fontIndex = List.findIndex (== font) fonts
      (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 []

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

  , codepointIndex :: Int

  , offsetX :: Int
  , offsetY :: Int
  , advanceX :: Int
  , advanceY :: Int

  , attachGlyph :: Maybe Glyph

  , decomposition :: Word64

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

  -- Unicode properties filled in by CodepointToGlyph.
  , joiningType :: Word32 -- kbts_unicode_joining_type JoiningType;
  , unicodeFlags :: Word8
  , syllabicClass :: Word8
  , syllabicPosition :: Word8
  , useClass :: Word8
  , combiningClass :: Word8
  }
  deriving (Eq, Show)

stripGlyph :: Structs.Glyph -> IO Glyph
stripGlyph Structs.Glyph{..} = do
  attached <-
    if attachGlyph == nullPtr then
      pure Nothing
    else
      Just <$> (peek attachGlyph >>= stripGlyph)
  pure Glyph
    { codepointIndex = userIdOrCodepointIndex
    , attachGlyph = attached
    , offsetX = fromIntegral offsetX
    , offsetY = fromIntegral offsetY
    , advanceX = fromIntegral advanceX
    , advanceY = fromIntegral advanceY
    , ..
    }