{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
module ZNC2 where

import Data.Array.Byte
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe qualified as BS
import Data.Text (Text)
import Data.Text.Internal qualified as TI
import Data.Text.Internal.Validate (isValidUtf8ByteArray)
import Foreign.C.Types
import Foreign.Ptr
import GHC.Exts
import GHC.IO (IO(IO))
import GHC.Word
import System.IO.Unsafe (unsafePerformIO)

import Util
import ZNC (Event(..))


foreign import ccall unsafe "tirclogv_parse_znc_numevents"
  --                       file buf     length      num events
  c_parse_znc_numevents :: Ptr CChar -> CSize -> IO CSize

foreign import ccall unsafe "tirclogv_parse_znc"
  --             events buffer                  file buf     length
  c_parse_znc :: MutableByteArray# RealWorld -> Ptr CChar -> CSize -> IO ()

foreign import ccall unsafe "tirclogv_fix_utf8_length"
  --                   byte buf      offset   length      length of fixed
  c_fix_utf8_length :: ByteArray# -> CSize -> CSize -> IO CSize

foreign import ccall unsafe "tirclogv_fix_utf8"
  --            output buffer                  byte buf      offset   length
  c_fix_utf8 :: MutableByteArray# RealWorld -> ByteArray# -> CSize -> CSize -> IO ()


-- For each event: (total 22 bytes)
-- * 1 byte hour
-- * 1 byte minute
-- * 1 byte second
-- * 1 byte event kind
-- * 4 bytes text pointer 1
-- * 4 bytes text pointer 2
-- * 4 bytes text pointer 3
-- * 2 bytes text length 1
-- * 2 bytes text length 2
-- * 2 bytes text length 3
data Events = Events ByteArray#  -- pinned

evRepSz :: Int
evRepSz = 20

parseLog :: ByteString -> [(HMS, Event)]
parseLog bs =
  let !(Events ba#) = parseLogToEvents bs
      nev = I# (sizeofByteArray# ba#) `quot` evRepSz
  in [deserialise ba# i | i <- [0 .. nev-1]]
  where
    deserialise :: ByteArray# -> Int -> (HMS, Event)
    deserialise ba# i =
      (HMS (byte 0) (byte 1) (byte 2)
      ,case byte 3 of
         0 -> Join   (textfield 0) (textfield 1)
         1 -> Part   (textfield 0) (textfield 1) (textfield 2)
         2 -> Quit   (textfield 0) (textfield 1) (textfield 2)
         3 -> ReNick (textfield 0) (textfield 1)
         4 -> Talk   (textfield 0) (textfield 1)
         5 -> Notice (textfield 0) (textfield 1)
         6 -> Act    (textfield 0) (textfield 1)
         7 -> Kick   (textfield 0) (textfield 1) (textfield 2)
         8 -> Mode   (textfield 0) (textfield 1)
         9 -> Topic  (textfield 0) (textfield 1)
         _ {- includes 10 -} -> ParseError
      )
      where
        byte :: Int -> Word8
        byte off = indexWord8Array ba# (i * evRepSz + off)

        textfield :: Int -> Text
        textfield n =
          let offset = fromIntegral @Word32 @Int (indexWord8ArrayAsWord32 ba# (i * evRepSz + 4 + 4 * n))
              len    = fromIntegral @Word16 @Int (indexWord8ArrayAsWord16 ba# (i * evRepSz + 16 + 2 * n))
          in if isValidUtf8ByteArray (ByteArray ba#) offset len
               then TI.Text (ByteArray ba#) offset len
               else fixUtf8ByteArray ba# offset len

    indexWord8ArrayAsWord32 :: ByteArray# -> Int -> Word32
    indexWord8ArrayAsWord32 ba# (I# i#) = W32# (indexWord8ArrayAsWord32# ba# i#)

    indexWord8ArrayAsWord16 :: ByteArray# -> Int -> Word16
    indexWord8ArrayAsWord16 ba# (I# i#) = W16# (indexWord8ArrayAsWord16# ba# i#)

    indexWord8Array :: ByteArray# -> Int -> Word8
    indexWord8Array ba# (I# i#) = W8# (indexWord8Array# ba# i#)

{-# NOINLINE parseLogToEvents #-}
parseLogToEvents :: ByteString -> Events
parseLogToEvents bs = unsafePerformIO $
  BS.unsafeUseAsCStringLen bs $ \(bsptr, bslen) -> do
    let bslenCS = fromIntegral @Int @CSize bslen
    numev <- c_parse_znc_numevents bsptr bslenCS
    let !(I# numbytes#) = fromIntegral @CSize @Int numev * evRepSz

    MutableByteArray dst# <-
      IO $ \s -> case newPinnedByteArray# numbytes# s of
                   (# s', mba# #) -> (# s', MutableByteArray mba# #)
    c_parse_znc dst# bsptr bslenCS
    IO $ \s -> case unsafeFreezeByteArray# dst# s of
                 (# s', ba# #) -> (# s', Events ba# #)

-- | Returns an unpinned byte array
{-# NOINLINE fixUtf8ByteArray #-}
fixUtf8ByteArray :: ByteArray# -> Int -> Int -> Text
fixUtf8ByteArray input# offset len = unsafePerformIO $ do
  let offCS = fromIntegral @Int @CSize offset
      lenCS = fromIntegral @Int @CSize len
  outlenCS <- c_fix_utf8_length input# offCS lenCS

  let !outlen@(I# outlen#) = fromIntegral @CSize @Int outlenCS
  MutableByteArray dst# <-
    IO $ \s -> case newByteArray# outlen# s of
                 (# s', mba# #) -> (# s', MutableByteArray mba# #)
  c_fix_utf8 dst# input# offCS lenCS
  IO $ \s -> case unsafeFreezeByteArray# dst# s of
               (# s', ba# #) -> (# s', TI.Text (ByteArray ba#) 0 outlen #)