-- | This module has no public functions, but provides the surface interface
-- between the Montis runtime and the world.
module Montis.Core.Internal.Foreign.Export () where

import Control.Monad (forM_)
import Control.Monad.State (MonadIO (liftIO), gets)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as CH
import Data.Singletons.Decide (Void)
import Foreign
  ( Ptr,
    Storable (poke, pokeByteOff),
    Word32,
    Word8,
    deRefStablePtr,
    freeStablePtr,
    mallocBytes,
    newStablePtr,
  )
import Foreign.C (CChar, CDouble (..), CInt (..))
import Foreign.Ptr (castPtr)
import Montis.Base.Foreign.WlRoots.Types
  ( ForeignSurface (toSurface),
    ForeignWlrInputDevice,
    ForeignWlrPointer,
    ForeignWlrXWaylandSurface,
    ForeignWlrXdgSurface,
    WlrEventKeyboardKey,
    WlrInputDevice (WlrInputDevice),
    WlrPointer (WlrPointer),
    WlrPointerButtonEvent,
  )
import Montis.Core
import Montis.Core.State
import Montis.Core.State.Marshal (marshalState)
import Montis.Foreign.Marshal (Demarshal (Demarshal), demarshal, runDemarshal)

-- | Helpers to unpack the opaque state, run a Montis action, and re-wrap it.
--   Each call consumes the old stable pointer and returns a fresh one.
runForeign ::
  Montis () ->
  OpqStT ->
  IO OpqStT
runForeign fn stableptr = do
  (ctx, st) <- deRefStablePtr stableptr
  freeStablePtr stableptr
  (_, state') <- runMontis ctx st fn
  newStablePtr (ctx, state')

runForeignWithReturn ::
  (Storable a) =>
  Montis a ->
  Ptr a ->
  OpqStT ->
  IO OpqStT
runForeignWithReturn fn outptr stableptr = do
  (ctx, st) <- deRefStablePtr stableptr
  freeStablePtr stableptr
  (val, state') <- runMontis ctx st fn
  poke outptr val
  newStablePtr (ctx, state')

-- ----------------------------------------------------------------------
-- State marshal/export

-- | Marshals the opaque state to a C-style byte array and size pointer.
foreign export ccall "arkworld_export_preserve"
  worldMarshalState :: OpqStT -> Ptr Word32 -> IO (Ptr Word8)

worldMarshalState :: OpqStT -> Ptr Word32 -> IO (Ptr Word8)
worldMarshalState opqStT outlen = do
  (_, st) <- deRefStablePtr opqStT
  let bs = CH.pack (marshalState st)
  ret <- mallocBytes (BS.length bs)
  poke outlen (fromIntegral $ BS.length bs)
  forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do
    pokeByteOff ret off w8
  return ret

-- ----------------------------------------------------------------------
-- Input handlers

foreign export ccall "arkworld_export_handle_button"
  worldHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> OpqStT -> IO OpqStT

worldHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> OpqStT -> IO OpqStT
worldHandleButton eventPtr modifiers =
  runForeign $ do
    s <- gets currentHooks
    event <- liftIO $
      runDemarshal eventPtr $ do
        -- Follows struct wlr_pointer_button_event field order.
        pointerPtr <- demarshal :: Demarshal (Ptr ForeignWlrPointer)
        tMs <- demarshal
        button <- demarshal
        state <- demarshal :: Demarshal Word8
        return $
          ButtonEvent
            (WlrPointer pointerPtr)
            tMs
            button
            modifiers
            (if state == (0 :: Word8) then ButtonReleased else ButtonPressed)

    buttonHook s event

-- ----------------------------------------------------------------------
-- Keybinding handler

foreign export ccall "arkworld_export_handle_keybinding"
  worldHandleKeybinding ::
    Ptr ForeignWlrInputDevice ->
    Ptr WlrEventKeyboardKey ->
    Word32 ->
    Word32 ->
    Word32 ->
    Ptr CInt ->
    OpqStT ->
    IO OpqStT

worldHandleKeybinding ::
  Ptr ForeignWlrInputDevice ->
  Ptr WlrEventKeyboardKey ->
  Word32 ->
  Word32 ->
  Word32 ->
  Ptr CInt ->
  OpqStT ->
  IO OpqStT
worldHandleKeybinding inputDevicePtr eventPtr mods sym cp =
  runForeignWithReturn $ do
    s <- gets currentHooks
    event <- liftIO $
      runDemarshal eventPtr $ do
        -- Matches struct wlr_keyboard_key_event in wlroots.
        tMs <- demarshal
        kc <- demarshal
        _ <- (demarshal :: Demarshal Word32)
        keyState <- demarshal
        return $
          KeyEvent
            tMs
            kc
            (if keyState == (0 :: Word8) then KeyReleased else KeyPressed)
            mods
            sym
            (toEnum $ fromIntegral cp)
            (WlrInputDevice inputDevicePtr)

    keyHook s event
    return 1

-- ----------------------------------------------------------------------
-- Motion handler

foreign export ccall "arkworld_export_handle_motion"
  worldHandleMotion :: Ptr Void -> Word32 -> Word32 -> CDouble -> CDouble -> OpqStT -> IO OpqStT

worldHandleMotion :: Ptr Void -> Word32 -> Word32 -> CDouble -> CDouble -> OpqStT -> IO OpqStT
worldHandleMotion eventPtr modifiers isAbsolute lx ly =
  runForeign $ do
    s <- gets currentHooks
    event <- liftIO $
      if isAbsolute == 0
        then
          runDemarshal (castPtr eventPtr) $ do
            pointerPtr <- demarshal :: Demarshal (Ptr ForeignWlrPointer)
            tMs <- demarshal
            _ <- demarshal :: Demarshal Word32
            _ <- demarshal :: Demarshal Double
            _ <- demarshal :: Demarshal Double
            _ <- demarshal :: Demarshal Double
            _ <- demarshal :: Demarshal Double
            return $
              MotionEvent
                (WlrPointer pointerPtr)
                tMs
                modifiers
                (realToFrac lx, realToFrac ly)
                (0, 0)
        else
          runDemarshal (castPtr eventPtr) $ do
            -- After time_msec, wlroots pads to 8-byte alignment for doubles.
            pointerPtr <- demarshal :: Demarshal (Ptr ForeignWlrPointer)
            tMs <- demarshal
            _ <- demarshal :: Demarshal Word32
            rawX <- demarshal
            rawY <- demarshal
            return $
              MotionEvent
                (WlrPointer pointerPtr)
                tMs
                modifiers
                (realToFrac lx, realToFrac ly)
                (rawX, rawY)

    motionHook s event

-- ----------------------------------------------------------------------
-- Surface handlers

-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XDG surface.
foreign export ccall "arkworld_export_handle_surface"
  worldHandleSurface ::
    Ptr ForeignWlrXdgSurface -> CInt -> OpqStT -> IO OpqStT

worldHandleSurface ::
  Ptr ForeignWlrXdgSurface -> CInt -> OpqStT -> IO OpqStT
worldHandleSurface p t =
  runForeign $ do
    s <- gets currentHooks
    surfaceHook s (SurfaceEvent (toEnum $ fromIntegral t) (toSurface p))

-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XWayland surface.
foreign export ccall "arkworld_export_handle_xwayland_surface"
  worldHandleXWaylandSurface ::
    Ptr ForeignWlrXWaylandSurface -> CInt -> OpqStT -> IO OpqStT

worldHandleXWaylandSurface ::
  Ptr ForeignWlrXWaylandSurface -> CInt -> OpqStT -> IO OpqStT
worldHandleXWaylandSurface p t =
  runForeign $ do
    s <- gets currentHooks
    surfaceHook s (SurfaceEvent (toEnum $ fromIntegral t) (toSurface p))