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

import Config
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 System.Posix.Types (CIno)
import Wetterhorn.Core
import Wetterhorn.Core.ForeignInterface

runForeign :: (WConfig -> W ()) -> Wetterhorn -> IO Wetterhorn
runForeign fn stblptr = do
  (ctx, st) <- deRefStablePtr stblptr
  freeStablePtr stblptr
  (_, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
  newStablePtr (ctx, state')

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

runForeignWithReturn2 :: (Storable a, Storable b) => (WConfig -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn2 fn ptrA ptrB stableptr = do
  (ctx, st) <- deRefStablePtr stableptr
  freeStablePtr stableptr
  ((vA, vB), state') <- runW (fn $ ctxConfig ctx) (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)
  wtrPtr <- wetterhorn
  (conf, _) <- deRefStablePtr wtrPtr
  freeStablePtr wtrPtr
  newStablePtr . (conf,) =<< readWState bs

-- | 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 = wetterhorn

-- | 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 (show 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_keybinding"
  pluginHandleKeybinding ::
    Ptr () ->
    Word32 ->
    Word32 ->
    Word32 ->
    Ptr CInt ->
    Wetterhorn ->
    IO Wetterhorn

pluginHandleKeybinding ::
  Ptr () ->
  Word32 ->
  Word32 ->
  Word32 ->
  Ptr CInt ->
  Wetterhorn ->
  IO Wetterhorn
pluginHandleKeybinding eventPtr mods sym cp =
  runForeignWithReturn $ \config -> do
    event <- 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)
    (\b -> if b then 1 else 0) <$> keybindingHandler config event

foreign export ccall "plugin_handle_surface_map"
  pluginHandleSurfaceMap ::
    Ptr () -> Wetterhorn -> IO Wetterhorn

pluginHandleSurfaceMap :: Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceMap p = runForeign (\c -> surfaceHandler c Map p)

foreign export ccall "plugin_handle_surface_unmap"
  pluginHandleSurfaceUnmap ::
    Ptr () -> Wetterhorn -> IO Wetterhorn

pluginHandleSurfaceUnmap :: Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceUnmap p = runForeign (\c -> surfaceHandler c Unmap p)

foreign export ccall "plugin_handle_surface_destroy"
  pluginHandleSurfaceDestroy ::
    Ptr () -> Wetterhorn -> IO Wetterhorn

pluginHandleSurfaceDestroy :: Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceDestroy p = runForeign (\c -> surfaceHandler c Destroy p)