-- | This module does not export anything. It exists simply to provide C-symbols
-- for the plugin.
module Wetterhorn.Foreign.Export () where

import Config
import Control.Arrow (Arrow (first))
import Control.Monad (forM_)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CH
import Foreign
  ( Ptr,
    Storable (poke, pokeByteOff),
    Word32,
    Word8,
    deRefStablePtr,
    freeStablePtr,
    mallocBytes,
    newStablePtr,
  )
import Foreign.C (CChar, CInt (..))
import Wetterhorn.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased))
import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..))
import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
import Wetterhorn.Core.W (W, Wetterhorn)
import qualified Wetterhorn.Core.W as W
import Wetterhorn.Foreign.ForeignInterface
import Wetterhorn.Foreign.WlRoots

type Wetter = (W.Config W.WindowLayout, W.State)

toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State)
toWetter = first W.ctxConfig

runForeign :: (Wetter -> W ()) -> Wetterhorn -> IO Wetterhorn
runForeign fn stblptr = do
  w@(ctx, st) <- deRefStablePtr stblptr
  freeStablePtr stblptr
  (_, state') <- W.runW (fn $ toWetter w) (ctx, st)
  newStablePtr (ctx, state')

runForeignWithReturn ::
  (Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn fn ptr stableptr = do
  w@(ctx, st) <- deRefStablePtr stableptr
  freeStablePtr stableptr
  (val, state') <- W.runW (fn $ toWetter w) (ctx, st)
  poke ptr val
  newStablePtr (ctx, state')

runForeignWithReturn2 ::
  (Storable a, Storable b) =>
  (Wetter -> W (a, b)) ->
  Ptr a ->
  Ptr b ->
  Wetterhorn ->
  IO Wetterhorn
runForeignWithReturn2 fn ptrA ptrB stableptr = do
  w@(ctx, st) <- deRefStablePtr stableptr
  freeStablePtr stableptr
  ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st)
  poke ptrA vA
  poke ptrB vB
  newStablePtr (ctx, state')

-- | This function is the implementation of the "hotstart" mechanism. It gives a
-- pointer to the previously marshalled state and the length of that array and
-- this function returns a Wetterhorn instance.
foreign export ccall "plugin_hot_start"
  pluginHotStart ::
    Ptr CChar -> Word32 -> IO Wetterhorn

pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn
pluginHotStart chars len = do
  bs <- BS.packCStringLen (chars, fromIntegral len)
  foreignInterface <- getForeignInterface
  wtr <-
    newStablePtr
      ( W.Context foreignInterface config,
        W.demarshalState config (CH.unpack bs)
      )
  runForeign (\(conf, _) -> W.resetHook conf) wtr

-- | This function is called when a "coldstart" request is receieved. It just
-- calles the function "wetterhorn". This function should be defined in the main
-- code as it's sort-of the equivalent of XMonad's "main" function.
foreign export ccall "plugin_cold_start"
  pluginColdStart :: IO Wetterhorn

pluginColdStart :: IO Wetterhorn
pluginColdStart = do
  foreignInterface <- getForeignInterface
  state <- W.initColdState config
  wtr <- newStablePtr (W.Context foreignInterface config, state)
  runForeign (\(conf, _) -> W.resetHook conf) wtr

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

pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
pluginMarshalState stblptr outlen = do
  (_, st) <- deRefStablePtr stblptr
  let bs = CH.pack (W.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

foreign export ccall "plugin_handle_button"
  pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn

pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn
pluginHandleButton eventPtr modifiers = do
  runForeign $
    \( _,
       W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}}
       ) -> do
        event <- W.wio $
          runForeignDemarshal eventPtr $ do
            ButtonEvent
              <$> demarshal
              <*> demarshal
              <*> demarshal
              <*> pure modifiers
              <*> ( ( \u8 ->
                        if (u8 :: Word8) == 0
                          then ButtonReleased
                          else ButtonPressed
                    )
                      <$> demarshal
                  )

        buttonHook event

foreign export ccall "plugin_handle_keybinding"
  pluginHandleKeybinding ::
    Ptr WlrInputDevice ->
    Ptr WlrEventKeyboardKey ->
    Word32 ->
    Word32 ->
    Word32 ->
    Ptr CInt ->
    Wetterhorn ->
    IO Wetterhorn

pluginHandleKeybinding ::
  Ptr WlrInputDevice ->
  Ptr WlrEventKeyboardKey ->
  Word32 ->
  Word32 ->
  Word32 ->
  Ptr CInt ->
  Wetterhorn ->
  IO Wetterhorn
pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
  runForeignWithReturn $
    \( _,
       W.State {W.currentHooks = W.Hooks {keyHook = keyHook}}
       ) -> do
        event <- W.wio $
          runForeignDemarshal eventPtr $ do
            tMs <- demarshal
            kc <- demarshal
            _ <- (demarshal :: ForeignDemarshal Word32)
            keyState <- demarshal
            return $
              KeyEvent
                tMs
                kc
                (if keyState == (0 :: Word8) then KeyReleased else KeyPressed)
                mods
                sym
                (toEnum $ fromIntegral cp)
                inputDevicePtr
        keyHook event
        return 1

-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XDG surface.
foreign export ccall "plugin_handle_surface"
  pluginHandleSurface ::
    Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn

pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleSurface p t =
  runForeign
    ( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) ->
        surfaceHook $
          SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
    )

-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XWayland surface.
foreign export ccall "plugin_handle_xwayland_surface"
  pluginHandleXWaylandSurface ::
    Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn

pluginHandleXWaylandSurface ::
  Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleXWaylandSurface p t =
  runForeign
    ( \( _,
         W.State
           { currentHooks = W.Hooks {surfaceHook = surfaceHook}
           }
         ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
    )