module Wetterhorn.Foreign.ForeignInterface
  ( getForeignInterface,
    ForeignInterface (..),
    ForeignDemarshal (..),
    runForeignDemarshal,
    demarshal,
    doShellExec,
  )
where

import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
import Data.Void (Void)
import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
import Foreign.C (CChar, CInt (..))
import Foreign.C.String
import GHC.Exts (FunPtr)
import Wetterhorn.Foreign.WlRoots

newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
  deriving (Functor, Monad, Applicative, MonadState (Ptr ()))

runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a
runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p)

demarshal :: (Storable a) => ForeignDemarshal a
demarshal = do
  ptr <- get
  val <- ForeignDemarshal $ lift $ peek $ castPtr ptr
  put (plusPtr ptr (sizeOf val))
  return val

type CtxT = Ptr Void

type ForeignCallGetPtr = CtxT -> IO (Ptr ())

type ForeignCall = CtxT -> IO ()

type ForeignCallStr = CtxT -> CString -> IO ()

type ForeignCallInt = CtxT -> CInt -> IO ()

foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ())

foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall

foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr

foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt

foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr

foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO ()

data ForeignInterface = ForeignInterface
  { requestHotReload :: IO (),
    requestLog :: String -> IO (),
    requestExit :: Int -> IO (),
    getSeat :: IO (Ptr WlrSeat)
  }

doShellExec :: String -> IO ()
doShellExec str = withCString str shellExec

getForeignInterface :: IO ForeignInterface
getForeignInterface = do
  ptr <- foreignInterfacePtr
  runForeignDemarshal ptr $ do
    ctx <- demarshal
    requestHotReloadFn <- demarshal
    doLogFn <- demarshal
    doRequestExit <- demarshal
    getSeatFn <- demarshal

    return $
      ForeignInterface
        { requestHotReload = toForeignCall requestHotReloadFn ctx,
          requestLog = \str ->
            withCString str $ \cs -> toForeignCallStr doLogFn ctx cs,
          requestExit = toForeignCallInt doRequestExit ctx . fromIntegral,
          getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx
        }