{-# LANGUAGE CPP #-}
{-|
Module      : Lua.Userdata
Copyright   : © 2017-2023 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb@hslua.org>
Stability   : beta
Portability : ForeignFunctionInterface

Bindings to HsLua-specific functions used to push Haskell values
as userdata.
-}
module Lua.Userdata
  ( hslua_fromuserdata
  , hslua_newhsuserdatauv
  , hslua_newudmetatable
  , hslua_putuserdata
  ) where

import Foreign.C (CInt (CInt), CString)
import Lua.Auxiliary (luaL_testudata)
import Lua.Primary (lua_newuserdatauv)
import Lua.Types
  ( LuaBool (..)
  , StackIndex (..)
  , State (..)
  )
import Foreign.Ptr (castPtr, nullPtr)
import Foreign.StablePtr (newStablePtr, deRefStablePtr, freeStablePtr)
import Foreign.Storable (peek, poke, sizeOf)

#ifdef ALLOW_UNSAFE_GC
#define SAFTY unsafe
#else
#define SAFTY safe
#endif

-- | Creates and registers a new metatable for a userdata-wrapped
-- Haskell value; checks whether a metatable of that name has been
-- registered yet and uses the registered table if possible.
foreign import ccall SAFTY "hsludata.h hslua_newudmetatable"
  hslua_newudmetatable :: State       -- ^ Lua state
                       -> CString     -- ^ Userdata name (__name)
                       -> IO LuaBool  -- ^ True iff new metatable
                                      --   was created.

-- | Creates a new userdata wrapping the given Haskell object, with
-- @nuvalue@ associated Lua values (uservalues).
hslua_newhsuserdatauv :: State
                      -> a      -- ^ value to be wrapped
                      -> CInt   -- ^ nuvalue
                      -> IO ()
hslua_newhsuserdatauv :: forall a. State -> a -> CInt -> IO ()
hslua_newhsuserdatauv State
l a
x CInt
nuvalue = do
  StablePtr a
xPtr <- forall a. a -> IO (StablePtr a)
newStablePtr a
x
  Ptr ()
udPtr <- State -> CSize -> CInt -> IO (Ptr ())
lua_newuserdatauv State
l (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
sizeOf StablePtr a
xPtr) CInt
nuvalue
  forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) StablePtr a
xPtr
{-# INLINABLE hslua_newhsuserdatauv #-}

-- | Retrieves a Haskell object from userdata at the given index.
-- The userdata /must/ have the given name.
hslua_fromuserdata :: State
                   -> StackIndex  -- ^ userdata index
                   -> CString     -- ^ name
                   -> IO (Maybe a)
hslua_fromuserdata :: forall a. State -> StackIndex -> CString -> IO (Maybe a)
hslua_fromuserdata State
l StackIndex
idx CString
name = do
  Ptr ()
udPtr <- State -> StackIndex -> CString -> IO (Ptr ())
luaL_testudata State
l StackIndex
idx CString
name
  if Ptr ()
udPtr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. StablePtr a -> IO a
deRefStablePtr)
{-# INLINABLE hslua_fromuserdata #-}

-- | Replaces the Haskell value contained in the userdata value at
-- @index@. Checks that the userdata is of type @name@ and returns
-- 'True' on success, or 'False' otherwise.
hslua_putuserdata :: State
                  -> StackIndex  -- ^ index
                  -> CString     -- ^ name
                  -> a           -- ^ new Haskell value
                  -> IO Bool
hslua_putuserdata :: forall a. State -> StackIndex -> CString -> a -> IO Bool
hslua_putuserdata State
l StackIndex
idx CString
name a
x = do
  StablePtr a
xPtr <- forall a. a -> IO (StablePtr a)
newStablePtr a
x
  Ptr ()
udPtr <- State -> StackIndex -> CString -> IO (Ptr ())
luaL_testudata State
l StackIndex
idx CString
name
  if Ptr ()
udPtr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr
    then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. StablePtr a -> IO ()
freeStablePtr
      forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) StablePtr a
xPtr
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
{-# INLINABLE hslua_putuserdata #-}