{-# 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 Font

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

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

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 - ttf"
  ttfGlyphsDirect <- mainAllocatorDirect testFontTtf 0
  putStrLn ""
  putStrLn "mainAllocatorDirect - blob"
  blobGlyphsDirect <- mainAllocatorDirect testFontBlob 0
  putStrLn ""

  if ttfGlyphsDirect == blobGlyphsDirect then
    putStrLn "Direct/Blob works"
  else
    error "Direct/Blob didn't quite work"

  mainFontInfo

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

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

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

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

oneshot :: Font.FontData -> Int -> [Char] -> IO [TextShape.Glyph]
oneshot fontData userId codepoints =
  Font.withFontData fontData \font ->
    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 :: (Ptr Structs.GlyphStorage -> IO b) -> IO b
withGlyphStorage action = alloca @Structs.GlyphStorage \ptr -> do
  fillBytes ptr 0 (sizeOf (undefined :: Structs.GlyphStorage))
  action ptr

withGlyphConfig :: (Handles.GlyphConfig -> IO c) -> IO c
withGlyphConfig =
  bracket
  (ShapeDirect.kbts_CreateGlyphConfig nullPtr 0 nullFunPtr nullPtr)
  ShapeDirect.kbts_DestroyGlyphConfig

pushCodepoints :: (Foldable t, Integral a) => TextShape.Font -> Ptr Structs.GlyphStorage -> Handles.GlyphConfig -> a -> t Char -> IO ()
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 <- Font.extractBlob ttfData 0
  putStrLn $ "Distilled into " <> show (ByteString.length blobData `div` 1024) <> "Kb blob"
  ByteString.writeFile testFontBlob blobData

mainFontInfo :: IO ()
mainFontInfo =
  TextShape.withContext \ctx -> do
    putStrLn "TTF:"
    ttf <- TextShape.pushFontFromFile ctx testFontTtf 0
    Font.getFontInfo ttf >>= print
    putStrLn "Blob:"
    blob <- TextShape.pushFontFromFile ctx testFontBlob 0
    Font.getFontInfo blob >>= print
    putStrLn $ "Units per em: " <> show (Font.unitsPerEm blob)
    putStrLn $ "Cap height: " <> show (Font.capHeight blob)
    putStrLn $ "em2caps factor: " <> show (Font.emToCaps blob :: Float)

-- 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)