{-# LANGUAGE OverloadedRecordDot #-}

import Control.Monad
import Data.Char
import Foreign
import Prelude hiding (id)

import Control.Exception (bracket)
import Data.ByteString qualified as ByteString
import Data.Text (Text)
import Data.Text qualified as Text

import KB.Text.Shape.FFI.API.Direct qualified as ShapeDirect
import KB.Text.Shape.FFI.Allocator (Allocator)
import KB.Text.Shape.FFI.Allocator qualified as Allocator
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

import KB.Text.Shape qualified as TextShape
import KB.Text.Shape.Font qualified as TextShape

testFontTtf :: FilePath
testFontTtf = "test/Ubuntu-R.ttf"

testFontBlob :: FilePath
testFontBlob = "test/Ubuntu-R.blob"

testText :: Text
testText = "Hello, ሰላም።, שלמלך, नमस्ते world!"

testCodepoints :: [Char]
testCodepoints = Text.unpack testText

main :: IO ()
main = do
  putStrLn "mainSimple"
  mainSimple
  putStrLn ""

  putStrLn "mainContext - ttf"
  ttfGlyphs <- mainContext testFontTtf
  putStrLn ""

  putStrLn "mainDistill"
  mainDistill
  putStrLn ""

  putStrLn "mainContext - blob"
  blobGlyphs <- mainContext testFontBlob
  putStrLn ""

  if ttfGlyphs == blobGlyphs then
    putStrLn "Context/Blob works"
  else
    error "Context/Blob didn't quite work"

  putStrLn ""
  putStrLn "mainAllocatorDirect"
  ttfGlyphsDirect <- mainAllocatorDirect testFontTtf 0
  blobGlyphsDirect <- mainAllocatorDirect testFontBlob 0
  if ttfGlyphsDirect == blobGlyphsDirect then
    putStrLn "Direct/Blob works"
  else
    error "Direct/Blob didn't quite work"

mainSimple :: IO ()
mainSimple = do
  TextShape.withContext \ctx -> do
    _font <- TextShape.pushFontFromFile ctx testFontTtf 0
    results <- TextShape.run ctx do
      TextShape.text_ "A bunch of characters"
      TextShape.char_ '!'
    forM_ results \(run, glyphs) -> do
      forM_ glyphs \glyph ->
        print (run.fontIndex, glyph.id)

mainContext :: FilePath -> IO [(TextShape.Run, [TextShape.Glyph])]
mainContext fontFile =
  TextShape.withContext \ctx -> do
    putStrLn $ "Loading font from " <> fontFile
    font <- TextShape.pushFontFromFile ctx fontFile 0 -- Run.fontIndex will be 1
    TextShape.pushFont ctx font -- Run.fontIndex will be 0
    results <- TextShape.run ctx do
      TextShape.text_ testText
      TextShape.char_ '!'
    writeFile "test/runs-and-glyphs.dump" $ show results
    forM results $ mapM dumpGlyphs

dumpGlyphs :: [TextShape.Glyph] -> IO [TextShape.Glyph]
dumpGlyphs =
  mapM \g@TextShape.Glyph{codepoint, id, advanceX, codepointIndex} -> do
    putStrLn $ chr (fromIntegral codepoint) : " | " <> show id <> ", " <> show advanceX <> " $" <> show codepointIndex
    pure g

mainAllocatorDirect :: FilePath -> Int -> IO [TextShape.Glyph]
mainAllocatorDirect fontFile fontIndex = do
  fontData <- ByteString.readFile fontFile
  TextShape.withFont fontData fontIndex \font -> do
    glyphs <- oneshot font 42 testCodepoints
    dumpGlyphs glyphs

oneshot :: Handles.Font -> Int -> [Char] -> IO [TextShape.Glyph]
oneshot font userId codepoints =
  withShapeConfig font script language \shapeConfig ->
    withGlyphStorage \glyphStoragePtr -> do
      withGlyphConfig \glyphConfig ->
        pushCodepoints font glyphStoragePtr glyphConfig userId codepoints
      shapeDirect shapeConfig glyphStoragePtr
  where
    script = Enums.SCRIPT_DONT_KNOW
    language = Enums.LANGUAGE_DONT_KNOW

withShapeConfig font script language =
  bracket
    (ShapeDirect.kbts_CreateShapeConfig font script language nullFunPtr nullPtr)
    ShapeDirect.kbts_DestroyShapeConfig

withGlyphStorage = alloca @Structs.GlyphStorage

withGlyphConfig =
  bracket
  (ShapeDirect.kbts_CreateGlyphConfig nullPtr 0 nullFunPtr nullPtr)
  ShapeDirect.kbts_DestroyGlyphConfig

pushCodepoints font glyphStoragePtr glyphConfig userId = mapM_ \codepoint ->
  ShapeDirect.kbts_PushGlyph
    glyphStoragePtr
    font
    (fromIntegral $ ord codepoint)
    glyphConfig
    (fromIntegral userId)

shapeDirect :: Handles.ShapeConfig -> Ptr Structs.GlyphStorage -> IO [TextShape.Glyph]
shapeDirect shapeConfig glyphStoragePtr =
  alloca \glyphItPtr -> do
    !err <- ShapeDirect.kbts_ShapeDirect
      shapeConfig
      glyphStoragePtr
      Enums.DIRECTION_DONT_KNOW
      nullFunPtr
      nullPtr
      glyphItPtr
    when (err /= Enums.SHAPE_ERROR_NONE) $
      error $ show err
    alloca \glyphOutPtr ->
      iterateGlyphs glyphOutPtr glyphItPtr

mainDistill :: IO ()
mainDistill = do
  ttfData <- ByteString.readFile testFontTtf
  putStrLn $ "Distilling " <> show (ByteString.length ttfData `div` 1024) <> "Kb of TTF"
  blobData <- TextShape.extractBlob ttfData 0
  putStrLn $ "Distilled into " <> show (ByteString.length blobData `div` 1024) <> "Kb blob"
  ByteString.writeFile testFontBlob blobData

-- some copypasta from unexported parts

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

------

_debugAllocator :: Allocator
_debugAllocator = hallocator opAllocate opFree
  where
    opAllocate size = do
      putStrLn $ "debugAllocator: request for " <> show size
      callocBytes size
    opFree ptr = do
      putStrLn $ "debugAllocator: release " <> show ptr
      free ptr

hallocator
  :: (Int -> IO (Ptr ()))
  -> (Ptr () -> IO ())
  -> Allocator
hallocator opAllocate opFree adPtr opPtr = do
  op <- peek opPtr
  case op.kind of
    Allocator.OP_KIND_ALLOCATE -> do
      ptr <- opAllocate (fromIntegral op.size)
      poke opPtr op{Allocator.pointer=ptr} -- Ugh...
    Allocator.OP_KIND_FREE ->
      opFree op.pointer
    _huh ->
      error . mappend "Allocator.OP_KIND_???: " $ show (adPtr, op)